home *** CD-ROM | disk | FTP | other *** search
/ Supercompiler 1997 / SUPERCOMPILER97.iso / Delphi 3.0 / DATA.Z / axctrls.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1997-01-30  |  90.9 KB  |  3,296 lines
  1. unit AxCtrls;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, ActiveX, SysUtils, ComObj, Classes, Graphics,
  7.   Controls, Forms, Consts, ExtCtrls, StdVcl;
  8.  
  9. type
  10.  
  11.   TOleStream = class(TStream)
  12.   private
  13.     FStream: IStream;
  14.   public
  15.     constructor Create(const Stream: IStream);
  16.     function Read(var Buffer; Count: Longint): Longint; override;
  17.     function Write(const Buffer; Count: Longint): Longint; override;
  18.     function Seek(Offset: Longint; Origin: Word): Longint; override;
  19.   end;
  20.  
  21.   TAggregatedObject = class
  22.   private
  23.     FController: Pointer;
  24.     function GetController: IUnknown;
  25.   protected
  26.     { IUnknown }
  27.     function QueryInterface(const IID: TGUID; out Obj): Integer; stdcall;
  28.     function _AddRef: Integer; stdcall;
  29.     function _Release: Integer; stdcall;
  30.   public
  31.     constructor Create(const Controller: IUnknown);
  32.     property Controller: IUnknown read GetController;
  33.   end;
  34.  
  35.   TContainedObject = class(TAggregatedObject, IUnknown)
  36.   protected
  37.     { IUnknown }
  38.     function QueryInterface(const IID: TGUID; out Obj): Integer; virtual; stdcall;
  39.   end;
  40.  
  41.   TConnectionPoints = class;
  42.  
  43.   TConnectEvent = procedure(const Sink: IUnknown) of object;
  44.  
  45.   TConnectionPoint = class(TContainedObject, IConnectionPoint)
  46.   private
  47.     FContainer: TConnectionPoints;
  48.     FIID: TGUID;
  49.     FSink: IUnknown;
  50.     FOnConnect: TConnectEvent;
  51.   protected
  52.     { IConnectionPoint }
  53.     function GetConnectionInterface(out iid: TIID): HResult; stdcall;
  54.     function GetConnectionPointContainer(
  55.       out cpc: IConnectionPointContainer): HResult; stdcall;
  56.     function Advise(const unkSink: IUnknown; out dwCookie: Longint): HResult; stdcall;
  57.     function Unadvise(dwCookie: Longint): HResult; stdcall;
  58.     function EnumConnections(out enum: IEnumConnections): HResult; stdcall;
  59.   public
  60.     constructor Create(Container: TConnectionPoints;
  61.       const IID: TGUID; OnConnect: TConnectEvent);
  62.     destructor Destroy; override;
  63.   end;
  64.  
  65.   TConnectionPoints = class(TAggregatedObject,
  66.     IConnectionPointContainer)
  67.   private
  68.     FConnectionPoints: TList;
  69.   protected
  70.     { IConnectionPointContainer }
  71.     function EnumConnectionPoints(
  72.       out enum: IEnumConnectionPoints): HResult; stdcall;
  73.     function FindConnectionPoint(const iid: TIID;
  74.       out cp: IConnectionPoint): HResult; stdcall;
  75.   public
  76.     constructor Create(const Controller: IUnknown);
  77.     destructor Destroy; override;
  78.     function CreateConnectionPoint(const IID: TGUID;
  79.       OnConnect: TConnectEvent): TConnectionPoint;
  80.   end;
  81.  
  82.   TDefinePropertyPage = procedure(const GUID: TGUID) of object;
  83.  
  84.   TActiveXControlFactory = class;
  85.  
  86.   IAmbientDispatch = dispinterface
  87.     ['{00020400-0000-0000-C000-000000000046}']
  88.     property BackColor: Integer dispid DISPID_AMBIENT_BACKCOLOR;
  89.     property DisplayName: WideString dispid DISPID_AMBIENT_DISPLAYNAME;
  90.     property Font: IFontDisp dispid DISPID_AMBIENT_FONT;
  91.     property ForeColor: Integer dispid DISPID_AMBIENT_FORECOLOR;
  92.     property LocaleID: Integer dispid DISPID_AMBIENT_LOCALEID;
  93.     property MessageReflect: WordBool dispid DISPID_AMBIENT_MESSAGEREFLECT;
  94.     property ScaleUnits: WideString dispid DISPID_AMBIENT_SCALEUNITS;
  95.     property TextAlign: Smallint dispid DISPID_AMBIENT_TEXTALIGN;
  96.     property UserMode: WordBool dispid DISPID_AMBIENT_USERMODE;
  97.     property UIDead: WordBool dispid DISPID_AMBIENT_UIDEAD;
  98.     property ShowGrabHandles: WordBool dispid DISPID_AMBIENT_SHOWGRABHANDLES;
  99.     property ShowHatching: WordBool dispid DISPID_AMBIENT_SHOWHATCHING;
  100.     property DisplayAsDefault: WordBool dispid DISPID_AMBIENT_DISPLAYASDEFAULT;
  101.     property SupportsMnemonics: WordBool dispid DISPID_AMBIENT_SUPPORTSMNEMONICS;
  102.     property AutoClip: WordBool dispid DISPID_AMBIENT_AUTOCLIP;
  103.   end;
  104.  
  105.   TActiveXControl = class(TAutoObject,
  106.     IPersistStreamInit,
  107.     IPersistStorage,
  108.     IOleObject,
  109.     IOleControl,
  110.     IOleInPlaceObject,
  111.     IOleInPlaceActiveObject,
  112.     IViewObject,
  113.     IViewObject2,
  114.     IPerPropertyBrowsing,
  115.     ISpecifyPropertyPages)
  116.   private
  117.     FControlFactory: TActiveXControlFactory;
  118.     FConnectionPoints: TConnectionPoints;
  119.     FEventSink: IUnknown;
  120.     FOleClientSite: IOleClientSite;
  121.     FOleControlSite: IOleControlSite;
  122.     FSimpleFrameSite: ISimpleFrameSite;
  123.     FAmbientDispatch: IAmbientDispatch;
  124.     FOleInPlaceSite: IOleInPlaceSite;
  125.     FOleInPlaceFrame: IOleInPlaceFrame;
  126.     FOleInPlaceUIWindow: IOleInPlaceUIWindow;
  127.     FOleAdviseHolder: IOleAdviseHolder;
  128.     FAdviseSink: IAdviseSink;
  129.     FAdviseFlags: Integer;
  130.     FControl: TWinControl;
  131.     FControlWndProc: TWndMethod;
  132.     FIsDirty: Boolean;
  133.     FInPlaceActive: Boolean;
  134.     FUIActive: Boolean;
  135.     FEventsFrozen: Boolean;
  136.     function CreateAdviseHolder: HResult;
  137.     procedure EventConnect(const Sink: IUnknown);
  138.     procedure RecreateWnd;
  139.     procedure ViewChanged;
  140.   protected
  141.     { Renamed methods }
  142.     function IPersistStreamInit.Load = PersistStreamLoad;
  143.     function IPersistStreamInit.Save = PersistStreamSave;
  144.     function IPersistStorage.InitNew = PersistStorageInitNew;
  145.     function IPersistStorage.Load = PersistStorageLoad;
  146.     function IPersistStorage.Save = PersistStorageSave;
  147.     function IViewObject2.GetExtent = ViewObjectGetExtent;
  148.     { IPersist }
  149.     function GetClassID(out classID: TCLSID): HResult; stdcall;
  150.     { IPersistStreamInit }
  151.     function IsDirty: HResult; stdcall;
  152.     function PersistStreamLoad(const stm: IStream): HResult; stdcall;
  153.     function PersistStreamSave(const stm: IStream;
  154.       fClearDirty: BOOL): HResult; stdcall;
  155.     function GetSizeMax(out cbSize: Largeint): HResult; stdcall;
  156.     function InitNew: HResult; stdcall;
  157.     { IPersistStorage }
  158.     function PersistStorageInitNew(const stg: IStorage): HResult; stdcall;
  159.     function PersistStorageLoad(const stg: IStorage): HResult; stdcall;
  160.     function PersistStorageSave(const stgSave: IStorage;
  161.       fSameAsLoad: BOOL): HResult; stdcall;
  162.     function SaveCompleted(const stgNew: IStorage): HResult; stdcall;
  163.     function HandsOffStorage: HResult; stdcall;
  164.     { IOleObject }
  165.     function SetClientSite(const clientSite: IOleClientSite): HResult;
  166.       stdcall;
  167.     function GetClientSite(out clientSite: IOleClientSite): HResult;
  168.       stdcall;
  169.     function SetHostNames(szContainerApp: POleStr;
  170.       szContainerObj: POleStr): HResult; stdcall;
  171.     function Close(dwSaveOption: Longint): HResult; stdcall;
  172.     function SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;
  173.       stdcall;
  174.     function GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  175.       out mk: IMoniker): HResult; stdcall;
  176.     function InitFromData(const dataObject: IDataObject; fCreation: BOOL;
  177.       dwReserved: Longint): HResult; stdcall;
  178.     function GetClipboardData(dwReserved: Longint;
  179.       out dataObject: IDataObject): HResult; stdcall;
  180.     function DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;
  181.       lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;
  182.       stdcall;
  183.     function EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult; stdcall;
  184.     function Update: HResult; stdcall;
  185.     function IsUpToDate: HResult; stdcall;
  186.     function GetUserClassID(out clsid: TCLSID): HResult; stdcall;
  187.     function GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;
  188.       stdcall;
  189.     function SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;
  190.       stdcall;
  191.     function GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;
  192.       stdcall;
  193.     function Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;
  194.       stdcall;
  195.     function Unadvise(dwConnection: Longint): HResult; stdcall;
  196.     function EnumAdvise(out enumAdvise: IEnumStatData): HResult; stdcall;
  197.     function GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;
  198.       stdcall;
  199.     function SetColorScheme(const logpal: TLogPalette): HResult; stdcall;
  200.     { IOleControl }
  201.     function GetControlInfo(var ci: TControlInfo): HResult; stdcall;
  202.     function OnMnemonic(msg: PMsg): HResult; stdcall;
  203.     function OnAmbientPropertyChange(dispid: TDispID): HResult; stdcall;
  204.     function FreezeEvents(bFreeze: BOOL): HResult; stdcall;
  205.     { IOleWindow }
  206.     function GetWindow(out wnd: HWnd): HResult; stdcall;
  207.     function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
  208.     { IOleInPlaceObject }
  209.     function InPlaceDeactivate: HResult; stdcall;
  210.     function UIDeactivate: HResult; stdcall;
  211.     function SetObjectRects(const rcPosRect: TRect;
  212.       const rcClipRect: TRect): HResult; stdcall;
  213.     function ReactivateAndUndo: HResult; stdcall;
  214.     { IOleInPlaceActiveObject }
  215.     function TranslateAccelerator(var msg: TMsg): HResult; stdcall;
  216.     function OnFrameWindowActivate(fActivate: BOOL): HResult; stdcall;
  217.     function OnDocWindowActivate(fActivate: BOOL): HResult; stdcall;
  218.     function ResizeBorder(const rcBorder: TRect; const uiWindow: IOleInPlaceUIWindow;
  219.       fFrameWindow: BOOL): HResult; stdcall;
  220.     function EnableModeless(fEnable: BOOL): HResult; stdcall;
  221.     { IViewObject }
  222.     function Draw(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  223.       ptd: PDVTargetDevice; hicTargetDev: HDC; hdcDraw: HDC;
  224.       prcBounds: PRect; prcWBounds: PRect; fnContinue: TContinueFunc;
  225.       dwContinue: Longint): HResult; stdcall;
  226.     function GetColorSet(dwDrawAspect: Longint; lindex: Longint;
  227.       pvAspect: Pointer; ptd: PDVTargetDevice; hicTargetDev: HDC;
  228.       out colorSet: PLogPalette): HResult; stdcall;
  229.     function Freeze(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  230.       out dwFreeze: Longint): HResult; stdcall;
  231.     function Unfreeze(dwFreeze: Longint): HResult; stdcall;
  232.     function SetAdvise(aspects: Longint; advf: Longint;
  233.       const advSink: IAdviseSink): HResult; stdcall;
  234.     function GetAdvise(pAspects: PLongint; pAdvf: PLongint;
  235.       out advSink: IAdviseSink): HResult; stdcall;
  236.     { IViewObject2 }
  237.     function ViewObjectGetExtent(dwDrawAspect: Longint; lindex: Longint;
  238.       ptd: PDVTargetDevice; out size: TPoint): HResult; stdcall;
  239.     { IPerPropertyBrowsing }
  240.     function GetDisplayString(dispid: TDispID; pbstr: PWideString): HResult; stdcall;
  241.     function MapPropertyToPage(dispid: TDispID; out clsid: TCLSID): HResult; stdcall;
  242.     function GetPredefinedStrings(dispid: TDispID; out caStringsOut: TCAPOleStr;
  243.       out caCookiesOut: TCALongint): HResult; stdcall;
  244.     function GetPredefinedValue(dispid: TDispID; dwCookie: Longint;
  245.       out varOut: Variant): HResult; stdcall;
  246.     { ISpecifyPropertyPages }
  247.     function GetPages(out pages: TCAGUID): HResult; stdcall;
  248.     { Standard properties }
  249.     function Get_BackColor: Integer; safecall;
  250.     function Get_Caption: WideString; safecall;
  251.     function Get_Enabled: WordBool; safecall;
  252.     function Get_Font: Font; safecall;
  253.     function Get_ForeColor: Integer; safecall;
  254.     function Get_HWnd: Integer; safecall;
  255.     function Get_TabStop: WordBool; safecall;
  256.     function Get_Text: WideString; safecall;
  257.     procedure Set_BackColor(Value: Integer); safecall;
  258.     procedure Set_Caption(const Value: WideString); safecall;
  259.     procedure Set_Enabled(Value: WordBool); safecall;
  260.     procedure Set_Font(const Value: Font); safecall;
  261.     procedure Set_ForeColor(Value: Integer); safecall;
  262.     procedure Set_TabStop(Value: WordBool); safecall;
  263.     procedure Set_Text(const Value: WideString); safecall;
  264.     { Standard event handlers }
  265.     procedure StdClickEvent(Sender: TObject);
  266.     procedure StdDblClickEvent(Sender: TObject);
  267.     procedure StdKeyDownEvent(Sender: TObject; var Key: Word;
  268.       Shift: TShiftState);
  269.     procedure StdKeyPressEvent(Sender: TObject; var Key: Char);
  270.     procedure StdKeyUpEvent(Sender: TObject; var Key: Word;
  271.       Shift: TShiftState);
  272.     procedure StdMouseDownEvent(Sender: TObject; Button: TMouseButton;
  273.       Shift: TShiftState; X, Y: Integer);
  274.     procedure StdMouseMoveEvent(Sender: TObject; Shift: TShiftState;
  275.       X, Y: Integer);
  276.     procedure StdMouseUpEvent(Sender: TObject; Button: TMouseButton;
  277.       Shift: TShiftState; X, Y: Integer);
  278.     { Helper methods }
  279.     function InPlaceActivate(ActivateUI: Boolean): HResult;
  280.     procedure ShowPropertyDialog;
  281.     { Overrideable methods }
  282.     procedure DefinePropertyPages(
  283.       DefinePropertyPage: TDefinePropertyPage); virtual;
  284.     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
  285.     function GetPropertyString(DispID: Integer;
  286.       var S: string): Boolean; virtual;
  287.     function GetPropertyStrings(DispID: Integer;
  288.       Strings: TStrings): Boolean; virtual;
  289.     procedure GetPropertyValue(DispID, Cookie: Integer;
  290.       var Value: OleVariant); virtual;
  291.     procedure InitializeControl; virtual;
  292.     procedure LoadFromStream(const Stream: IStream); virtual;
  293.     procedure PerformVerb(Verb: Integer); virtual;
  294.     procedure SaveToStream(const Stream: IStream); virtual;
  295.     procedure WndProc(var Message: TMessage); virtual;
  296.   public
  297.     destructor Destroy; override;
  298.     procedure Initialize; override;
  299.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; override;
  300.     property Control: TWinControl read FControl;
  301.   end;
  302.  
  303.   TActiveXControlClass = class of TActiveXControl;
  304.  
  305.   TActiveXControlFactory = class(TAutoObjectFactory)
  306.   private
  307.     FWinControlClass: TWinControlClass;
  308.     FMiscStatus: Integer;
  309.     FToolboxBitmapID: Integer;
  310.     FEventTypeInfo: ITypeInfo;
  311.     FEventIID: TGUID;
  312.     FVerbs: TStringList;
  313.     FLicFileStrings: TStringList;
  314.     FLicenseFileRead: Boolean;
  315.   protected
  316.     function GetLicenseFileName: string; virtual;
  317.     function HasMachineLicense: Boolean; override;
  318.   public
  319.     constructor Create(ComServer: TComServerObject;
  320.       ActiveXControlClass: TActiveXControlClass;
  321.       WinControlClass: TWinControlClass; const ClassID: TGUID;
  322.       ToolboxBitmapID: Integer; const LicStr: string);
  323.     destructor Destroy; override;
  324.     procedure AddVerb(Verb: Integer; const VerbName: string);
  325.     procedure UpdateRegistry(Register: Boolean); override;
  326.     property EventIID: TGUID read FEventIID;
  327.     property EventTypeInfo: ITypeInfo read FEventTypeInfo;
  328.     property MiscStatus: Integer read FMiscStatus;
  329.     property ToolboxBitmapID: Integer read FToolboxBitmapID;
  330.     property WinControlClass: TWinControlClass read FWinControlClass;
  331.   end;
  332.  
  333.   { ActiveFormControl }
  334.  
  335.   TActiveFormControl = class(TActiveXControl, IVCLComObject)
  336.   protected
  337.     procedure EventSinkChanged(const EventSink: IUnknown); override;
  338.   public
  339.     procedure FreeOnRelease;
  340.     procedure InitializeControl; override;
  341.     function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
  342.       Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
  343.       override;
  344.     function ObjQueryInterface(const IID: TGUID; out Obj): Integer; override;
  345.   end;
  346.  
  347.   { ActiveForm }
  348.  
  349.   TActiveFormBorderStyle = (afbNone, afbSingle, afbSunken, afbRaised);
  350.  
  351.   TActiveForm = class(TCustomForm)
  352.   private
  353.     FAxBorderStyle: TActiveFormBorderStyle;
  354.     procedure SetAxBorderStyle(Value: TActiveFormBorderStyle);
  355.   protected
  356.     procedure CreateParams(var Params: TCreateParams); override;
  357.     procedure EventSinkChanged(const EventSink: IUnknown); virtual;
  358.     procedure Initialize; virtual;
  359.   public
  360.     constructor Create(AOwner: TComponent); override;
  361.   published
  362.     property ActiveControl;
  363.     property AutoScroll;
  364.     property AxBorderStyle: TActiveFormBorderStyle read FAxBorderStyle
  365.       write SetAxBorderStyle default afbSingle;
  366.     property Caption stored True;
  367.     property Color;
  368.     property Font;
  369.     property Height stored True;
  370.     property HorzScrollBar;
  371.     property KeyPreview;
  372.     property PixelsPerInch;
  373.     property PopupMenu;
  374.     property PrintScale;
  375.     property Scaled;
  376.     property ShowHint;
  377.     property VertScrollBar;
  378.     property Width stored True;
  379.     property OnActivate;
  380.     property OnClick;
  381.     property OnCreate;
  382.     property OnDblClick;
  383.     property OnDestroy;
  384.     property OnDeactivate;
  385.     property OnDragDrop;
  386.     property OnDragOver;
  387.     property OnKeyDown;
  388.     property OnKeyPress;
  389.     property OnKeyUp;
  390.     property OnMouseDown;
  391.     property OnMouseMove;
  392.     property OnMouseUp;
  393.     property OnPaint;
  394.   end;
  395.  
  396.   TActiveFormClass = class of TActiveForm;
  397.  
  398.   { ActiveFormFactory }
  399.  
  400.   TActiveFormFactory = class(TActiveXControlFactory)
  401.   public
  402.     function GetIntfEntry(Guid: TGUID): PInterfaceEntry; override;
  403.   end;
  404.  
  405.   { Property Page support }
  406.  
  407.   TActiveXPropertyPage = class;
  408.  
  409.   TPropertyPage = class(TCustomForm)
  410.   private
  411.     FActiveXPropertyPage: TActiveXPropertyPage;
  412.     FOleObject: Variant;
  413.     procedure CMChanged(var Msg: TCMChanged); message CM_CHANGED;
  414.   public
  415.     procedure Modified;
  416.     procedure UpdateObject; virtual;
  417.     procedure UpdatePropertyPage; virtual;
  418.     property OleObject: Variant read FOleObject;
  419.     procedure EnumCtlProps(PropType: TGUID; PropNames: TStrings);
  420.   published
  421.     property ActiveControl;
  422.     property AutoScroll;
  423.     property Caption;
  424.     property ClientHeight;
  425.     property ClientWidth;
  426.     property Ctl3D;
  427.     property Color;
  428.     property Enabled;
  429.     property Font;
  430.     property Height;
  431.     property HorzScrollBar;
  432.     property KeyPreview;
  433.     property PixelsPerInch;
  434.     property ParentFont;
  435.     property PopupMenu;
  436.     property PrintScale;
  437.     property Scaled;
  438.     property ShowHint;
  439.     property VertScrollBar;
  440.     property Visible;
  441.     property Width;
  442.     property OnActivate;
  443.     property OnClick;
  444.     property OnClose;
  445.     property OnCloseQuery; {!!!}
  446.     property OnCreate;
  447.     property OnDblClick;
  448.     property OnDestroy;
  449.     property OnDeactivate;
  450.     property OnDragDrop;
  451.     property OnDragOver;
  452.     property OnHide;
  453.     property OnKeyDown;
  454.     property OnKeyPress;
  455.     property OnKeyUp;
  456.     property OnMouseDown;
  457.     property OnMouseMove;
  458.     property OnMouseUp;
  459.     property OnPaint;
  460.     property OnResize;
  461.     property OnShow;
  462.   end;
  463.  
  464.   TPropertyPageClass = class of TPropertyPage;
  465.  
  466.   TActiveXPropertyPage = class(TComObject,
  467.     IPropertyPage,
  468.     IPropertyPage2)
  469.   private
  470.     FPropertyPage: TPropertyPage;
  471.     FPageSite: IPropertyPageSite;
  472.     FActive: Boolean;
  473.     FModified: Boolean;
  474.     procedure Modified;
  475.   protected
  476.     { IPropertyPage }
  477.     function SetPageSite(const pageSite: IPropertyPageSite): HResult; stdcall;
  478.     function Activate(hwndParent: HWnd; const rc: TRect; bModal: BOOL): HResult;
  479.       stdcall;
  480.     function Deactivate: HResult; stdcall;
  481.     function GetPageInfo(out pageInfo: TPropPageInfo): HResult; stdcall;
  482.     function SetObjects(cObjects: Longint; pUnkList: PUnknownList): HResult; stdcall;
  483.     function Show(nCmdShow: Integer): HResult; stdcall;
  484.     function Move(const rect: TRect): HResult; stdcall;
  485.     function IsPageDirty: HResult; stdcall;
  486.     function Apply: HResult; stdcall;
  487.     function Help(pszHelpDir: POleStr): HResult; stdcall;
  488.     function TranslateAccelerator(msg: PMsg): HResult; stdcall;
  489.     { IPropertyPage2 }
  490.     function EditProperty(dispid: TDispID): HResult; stdcall;
  491.   public
  492.     destructor Destroy; override;
  493.     procedure Initialize; override;
  494.   end;
  495.  
  496.   TActiveXPropertyPageFactory = class(TComObjectFactory)
  497.   protected
  498.     function CreateComObject(const Controller: IUnknown): TComObject; override;
  499.   public
  500.     constructor Create(ComServer: TComServerObject;
  501.       PropertyPageClass: TPropertyPageClass; const ClassID: TGUID);
  502.   end;
  503.  
  504.   { Type adapter support }
  505.  
  506.   TCustomAdapter = class(TInterfacedObject)
  507.   private
  508.     FOleObject: IUnknown;
  509.     FConnection: Longint;
  510.     FNotifier: IUnknown;
  511.   protected
  512.     Updating: Boolean;
  513.     procedure Changed; virtual;
  514.     procedure ConnectOleObject(OleObject: IUnknown);
  515.     procedure ReleaseOleObject;
  516.     procedure Update; virtual; abstract;
  517.   public
  518.     constructor Create;
  519.     destructor Destroy; override;
  520.   end;
  521.  
  522.   TAdapterNotifier = class(TInterfacedObject,
  523.     IPropertyNotifySink)
  524.   private
  525.     FAdapter: TCustomAdapter;
  526.   protected
  527.     { IPropertyNotifySink }
  528.     function OnChanged(dispid: TDispID): HResult; stdcall;
  529.     function OnRequestEdit(dispid: TDispID): HResult; stdcall;
  530.   public
  531.     constructor Create(Adapter: TCustomAdapter);
  532.   end;
  533.  
  534.   IFontAccess = interface
  535.     ['{CBA55CA0-0E57-11D0-BD2F-0020AF0E5B81}']
  536.     procedure GetOleFont(var OleFont: IFontDisp);
  537.     procedure SetOleFont(const OleFont: IFontDisp);
  538.   end;
  539.  
  540.   TFontAdapter = class(TCustomAdapter,
  541.     IChangeNotifier,
  542.     IFontAccess)
  543.   private
  544.     FFont: TFont;
  545.   protected
  546.     { IFontAccess }
  547.     procedure GetOleFont(var OleFont: IFontDisp);
  548.     procedure SetOleFont(const OleFont: IFontDisp);
  549.     procedure Changed; override;
  550.     procedure Update; override;
  551.   public
  552.     constructor Create(Font: TFont);
  553.   end;
  554.  
  555.   IPictureAccess = interface
  556.     ['{795D4D31-43D7-11D0-9E92-0020AF3D82DA}']
  557.     procedure GetOlePicture(var OlePicture: IPictureDisp);
  558.     procedure SetOlePicture(const OlePicture: IPictureDisp);
  559.   end;
  560.  
  561.   TPictureAdapter = class(TCustomAdapter,
  562.     IChangeNotifier,
  563.     IPictureAccess)
  564.   private
  565.     FPicture: TPicture;
  566.   protected
  567.     { IPictureAccess }
  568.     procedure GetOlePicture(var OlePicture: IPictureDisp);
  569.     procedure SetOlePicture(const OlePicture: IPictureDisp);
  570.     procedure Update; override;
  571.   public
  572.     constructor Create(Picture: TPicture);
  573.   end;
  574.  
  575.   TOleGraphic = class(TGraphic)
  576.   private
  577.     FPicture: IPicture;
  578.     function GetMMHeight: Integer;
  579.     function GetMMWidth: Integer;
  580.   protected
  581.     procedure Changed(Sender: TObject); override;
  582.     procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
  583.     function GetEmpty: Boolean; override;
  584.     function GetHeight: Integer; override;
  585.     function GetPalette: HPALETTE; override;
  586.     function GetTransparent: Boolean; override;
  587.     function GetWidth: Integer; override;
  588.     procedure SetHeight(Value: Integer); override;
  589.     procedure SetPalette(Value: HPALETTE); override;
  590.     procedure SetWidth(Value: Integer); override;
  591.   public
  592.     procedure Assign(Source: TPersistent); override;
  593.     procedure LoadFromFile(const Filename: string); override;
  594.     procedure LoadFromStream(Stream: TStream); override;
  595.     procedure SaveToStream(Stream: TStream); override;
  596.     procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  597.       APalette: HPALETTE); override;
  598.     procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
  599.       var APalette: HPALETTE); override;
  600.     property MMHeight: Integer read GetMMHeight;      // in .01 mm units
  601.     property MMWidth: Integer read GetMMWidth;
  602.     property Picture: IPicture read FPicture write FPicture;
  603.   end;
  604.  
  605.   TStringsAdapter = class(TAutoIntfObject, IStrings, IStringsAdapter)
  606.   private
  607.     FStrings: TStrings;
  608.   protected
  609.     { IStringsAdapter }
  610.     procedure ReferenceStrings(S: TStrings);
  611.     procedure ReleaseStrings;
  612.     { IStrings }
  613.     function Get_ControlDefault(Index: Integer): OleVariant; safecall;
  614.     procedure Set_ControlDefault(Index: Integer; Value: OleVariant); safecall;
  615.     function Count: Integer; safecall;
  616.     function Get_Item(Index: Integer): OleVariant; safecall;
  617.     procedure Set_Item(Index: Integer; Value: OleVariant); safecall;
  618.     procedure Remove(Index: Integer); safecall;
  619.     procedure Clear; safecall;
  620.     function Add(Item: OleVariant): Integer; safecall;
  621.     function _NewEnum: IUnknown; safecall;
  622.   public
  623.     constructor Create(Strings: TStrings);
  624.   end;
  625.  
  626. procedure GetOleFont(Font: TFont; var OleFont: IFontDisp);
  627. procedure SetOleFont(Font: TFont; const OleFont: IFontDisp);
  628. procedure GetOlePicture(Picture: TPicture; var OlePicture: IPictureDisp);
  629. procedure SetOlePicture(Picture: TPicture; const OlePicture: IPictureDisp);
  630. procedure GetOleStrings(Strings: TStrings; var OleStrings: IStrings);
  631. procedure SetOleStrings(Strings: TStrings; const OleStrings: IStrings);
  632.  
  633. implementation
  634.  
  635. const
  636.   OCM_BASE = $2000;
  637.  
  638. type
  639.  
  640.   TWinControlAccess = class(TWinControl);
  641.  
  642.   IStdEvents = dispinterface
  643.     ['{00020400-0000-0000-C000-000000000046}']
  644.     procedure Click; dispid DISPID_CLICK;
  645.     procedure DblClick; dispid DISPID_DBLCLICK;
  646.     procedure KeyDown(var KeyCode: Smallint;
  647.       Shift: Smallint); dispid DISPID_KEYDOWN;
  648.     procedure KeyPress(var KeyAscii: Smallint); dispid DISPID_KEYPRESS;
  649.     procedure KeyUp(var KeyCode: Smallint;
  650.       Shift: Smallint); dispid DISPID_KEYDOWN;
  651.     procedure MouseDown(Button, Shift: Smallint;
  652.       X, Y: Integer); dispid DISPID_MOUSEDOWN;
  653.     procedure MouseMove(Button, Shift: Smallint;
  654.       X, Y: Integer); dispid DISPID_MOUSEMOVE;
  655.     procedure MouseUp(Button, Shift: Smallint;
  656.       X, Y: Integer); dispid DISPID_MOUSEUP;
  657.   end;
  658.  
  659. var
  660.   xParkingWindow: HWnd;
  661.  
  662. { Dynamically load functions used in OLEPRO32.DLL }
  663.  
  664. function OleCreatePropertyFrame(hwndOwner: HWnd; x, y: Integer;
  665.   lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
  666.   pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
  667.   pvReserved: Pointer): HResult; forward;
  668. function OleCreateFontIndirect(const FontDesc: TFontDesc; const iid: TIID;
  669.   out vObject): HResult; forward;
  670. function OleCreatePictureIndirect(const PictDesc: TPictDesc; const iid: TIID;
  671.   fOwn: BOOL; out vObject): HResult; forward;
  672.  
  673. function ParkingWindow: HWnd;
  674. var
  675.   TempClass: TWndClass;
  676. begin
  677.   Result := xParkingWindow;
  678.   if Result <> 0 then Exit;
  679.  
  680.   FillChar(TempClass, sizeof(TempClass), 0);
  681.   if not GetClassInfo(HInstance, 'DAXParkingWindow', TempClass) then
  682.   begin
  683.     TempClass.hInstance := HInstance;
  684.     TempClass.lpfnWndProc := @DefWindowProc;
  685.     TempClass.lpszClassName := 'DAXParkingWindow';
  686.     if Windows.RegisterClass(TempClass) = 0 then
  687.       raise EOutOfResources.Create(SWindowClass);
  688.   end;
  689.   xParkingWindow := CreateWindowEx(WS_EX_TOOLWINDOW, TempClass.lpszClassName, nil,
  690.     WS_POPUP, GetSystemMetrics(SM_CXSCREEN) div 2,
  691.     GetSystemMetrics(SM_CYSCREEN) div 2, 0, 0, 0, 0, HInstance, nil);
  692.   SetWindowPos(xParkingWindow, 0, 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOREDRAW
  693.     or SWP_NOZORDER or SWP_SHOWWINDOW);
  694.   Result := xParkingWindow;
  695. end;
  696.  
  697. function HandleException: HResult;
  698. var
  699.   E: TObject;
  700. begin
  701.   E := ExceptObject;
  702.   if (E is EOleSysError) and (EOleSysError(E).ErrorCode < 0) then
  703.     Result := EOleSysError(E).ErrorCode else
  704.     Result := E_UNEXPECTED;
  705. end;
  706.  
  707. procedure FreeObjects(List: TList);
  708. var
  709.   I: Integer;
  710. begin
  711.   for I := List.Count - 1 downto 0 do TObject(List[I]).Free;
  712. end;
  713.  
  714. procedure FreeObjectList(List: TList);
  715. begin
  716.   if List <> nil then
  717.   begin
  718.     FreeObjects(List);
  719.     List.Free;
  720.   end;
  721. end;
  722.  
  723. function CoAllocMem(Size: Integer): Pointer;
  724. begin
  725.   Result := CoTaskMemAlloc(Size);
  726.   if Result = nil then OleError(E_OUTOFMEMORY);
  727.   FillChar(Result^, Size, 0);
  728. end;
  729.  
  730. procedure CoFreeMem(P: Pointer);
  731. begin
  732.   if P <> nil then CoTaskMemFree(P);
  733. end;
  734.  
  735. function CoAllocString(const S: string): POleStr;
  736. var
  737.   W: WideString;
  738.   Size: Integer;
  739. begin
  740.   W := S;
  741.   Size := (Length(W) + 1) * 2;
  742.   Result := CoAllocMem(Size);
  743.   Move(PWideChar(W)^, Result^, Size);
  744. end;
  745.  
  746. { Connect an IConnectionPoint interface }
  747.  
  748. procedure InterfaceConnect(const Source: IUnknown; const IID: TIID;
  749.   const Sink: IUnknown; var Connection: Longint);
  750. var
  751.   CPC: IConnectionPointContainer;
  752.   CP: IConnectionPoint;
  753. begin
  754.   Connection := 0;
  755.   if Source.QueryInterface(IConnectionPointContainer, CPC) >= 0 then
  756.     if CPC.FindConnectionPoint(IID, CP) >= 0 then
  757.       CP.Advise(Sink, Connection);
  758. end;
  759.  
  760. { Disconnect an IConnectionPoint interface }
  761.  
  762. procedure InterfaceDisconnect(const Source: IUnknown; const IID: TIID;
  763.   var Connection: Longint);
  764. var
  765.   CPC: IConnectionPointContainer;
  766.   CP: IConnectionPoint;
  767. begin
  768.   if Connection <> 0 then
  769.     if Source.QueryInterface(IConnectionPointContainer, CPC) >= 0 then
  770.       if CPC.FindConnectionPoint(IID, CP) >= 0 then
  771.         if CP.Unadvise(Connection) >= 0 then Connection := 0;
  772. end;
  773.  
  774. function GetFontAccess(Font: TFont): IFontAccess;
  775. begin
  776.   if Font.FontAdapter = nil then
  777.     Font.FontAdapter := TFontAdapter.Create(Font);
  778.   Result := Font.FontAdapter as IFontAccess;
  779. end;
  780.  
  781. function GetPictureAccess(Picture: TPicture): IPictureAccess;
  782. begin
  783.   if Picture.PictureAdapter = nil then
  784.     Picture.PictureAdapter := TPictureAdapter.Create(Picture);
  785.   Result := Picture.PictureAdapter as IPictureAccess;
  786. end;
  787.  
  788. procedure GetOleFont(Font: TFont; var OleFont: IFontDisp);
  789. begin
  790.   GetFontAccess(Font).GetOleFont(OleFont);
  791. end;
  792.  
  793. procedure SetOleFont(Font: TFont; const OleFont: IFontDisp);
  794. begin
  795.   GetFontAccess(Font).SetOleFont(OleFont);
  796. end;
  797.  
  798. procedure GetOlePicture(Picture: TPicture; var OlePicture: IPictureDisp);
  799. begin
  800.   GetPictureAccess(Picture).GetOlePicture(OlePicture);
  801. end;
  802.  
  803. procedure SetOlePicture(Picture: TPicture; const OlePicture: IPictureDisp);
  804. begin
  805.   GetPictureAccess(Picture).SetOlePicture(OlePicture);
  806. end;
  807.  
  808. function GetKeyModifiers: Integer;
  809. begin
  810.   Result := 0;
  811.   if GetKeyState(VK_SHIFT) < 0 then Result := 1;
  812.   if GetKeyState(VK_CONTROL) < 0 then Result := Result or 2;
  813.   if GetKeyState(VK_MENU) < 0 then Result := Result or 4;
  814. end;
  815.  
  816. function GetEventShift(Shift: TShiftState): Integer;
  817. const
  818.   ShiftMap: array[0..7] of Byte = (0, 1, 4, 5, 2, 3, 6, 7);
  819. begin
  820.   Result := ShiftMap[Byte(Shift) and 7];
  821. end;
  822.  
  823. function GetEventButton(Button: TMouseButton): Integer;
  824. begin
  825.   Result := 1 shl Ord(Button);
  826. end;
  827.  
  828. { TOleStream }
  829.  
  830. constructor TOleStream.Create(const Stream: IStream);
  831. begin
  832.   FStream := Stream;
  833. end;
  834.  
  835. function TOleStream.Read(var Buffer; Count: Longint): Longint;
  836. begin
  837.   OleCheck(FStream.Read(@Buffer, Count, @Result));
  838. end;
  839.  
  840. function TOleStream.Seek(Offset: Longint; Origin: Word): Longint;
  841. var
  842.   Pos: Largeint;
  843. begin
  844.   OleCheck(FStream.Seek(Offset, Origin, Pos));
  845.   Result := Round(Pos);
  846. end;
  847.  
  848. function TOleStream.Write(const Buffer; Count: Longint): Longint;
  849. begin
  850.   OleCheck(FStream.Write(@Buffer, Count, @Result));
  851. end;
  852.  
  853. { TAggregatedObject }
  854.  
  855. constructor TAggregatedObject.Create(const Controller: IUnknown);
  856. begin
  857.   FController := Pointer(Controller);
  858. end;
  859.  
  860. function TAggregatedObject.GetController: IUnknown;
  861. begin
  862.   Result := IUnknown(FController);
  863. end;
  864.  
  865. { TAggregatedObject.IUnknown }
  866.  
  867. function TAggregatedObject.QueryInterface(const IID: TGUID; out Obj): Integer;
  868. begin
  869.   Result := IUnknown(FController).QueryInterface(IID, Obj);
  870. end;
  871.  
  872. function TAggregatedObject._AddRef: Integer;
  873. begin
  874.   Result := IUnknown(FController)._AddRef;
  875. end;
  876.  
  877. function TAggregatedObject._Release: Integer; stdcall;
  878. begin
  879.   Result := IUnknown(FController)._Release;
  880. end;
  881.  
  882. { TContainedObject.IUnknown }
  883.  
  884. function TContainedObject.QueryInterface(const IID: TGUID; out Obj): Integer;
  885. begin
  886.   if GetInterface(IID, Obj) then Result := S_OK else Result := E_NOINTERFACE;
  887. end;
  888.  
  889. { TEnumConnections }
  890.  
  891. type
  892.   TEnumConnections = class(TContainedObject, IEnumConnections)
  893.   private
  894.     FConnectionPoint: TConnectionPoint;
  895.     FIndex: Integer;
  896.     FCount: Integer;
  897.   protected
  898.     { IEnumConnections }
  899.     function Next(celt: Longint; out elt;
  900.       pceltFetched: PLongint): HResult; stdcall;
  901.     function Skip(celt: Longint): HResult; stdcall;
  902.     function Reset: HResult; stdcall;
  903.     function Clone(out enum: IEnumConnections): HResult; stdcall;
  904.   public
  905.     constructor Create(ConnectionPoint: TConnectionPoint; Index: Integer);
  906.   end;
  907.  
  908. constructor TEnumConnections.Create(ConnectionPoint: TConnectionPoint;
  909.   Index: Integer);
  910. begin
  911.   inherited Create(ConnectionPoint.Controller);
  912.   FConnectionPoint := ConnectionPoint;
  913.   FIndex := Index;
  914.   if FConnectionPoint.FSink <> nil then FCount := 1;
  915. end;
  916.  
  917. { TEnumConnections.IEnumConnections }
  918.  
  919. function TEnumConnections.Next(celt: Longint; out elt;
  920.   pceltFetched: PLongint): HResult;
  921. var
  922.   I: Integer;
  923. begin
  924.   I := 0;
  925.   if (celt > 0) and (FIndex < FCount) then
  926.   begin
  927.     Pointer(TConnectData(elt).pUnk) := nil;
  928.     TConnectData(elt).pUnk := FConnectionPoint.FSink;
  929.     TConnectData(elt).dwCookie := 1;
  930.     Inc(I);
  931.     Inc(FIndex);
  932.   end;
  933.   if pceltFetched <> nil then pceltFetched^ := I;
  934.   if I = celt then Result := S_OK else Result := S_FALSE;
  935. end;
  936.  
  937. function TEnumConnections.Skip(celt: Longint): HResult; stdcall;
  938. begin
  939.   if FIndex + celt <= FCount then
  940.   begin
  941.     FIndex := FIndex + celt;
  942.     Result := S_OK;
  943.   end else
  944.   begin
  945.     FIndex := FCount;
  946.     Result := S_FALSE;
  947.   end;
  948. end;
  949.  
  950. function TEnumConnections.Reset: HResult; stdcall;
  951. begin
  952.   FIndex := 0;
  953.   Result := S_OK;
  954. end;
  955.  
  956. function TEnumConnections.Clone(
  957.   out enum: IEnumConnections): HResult; stdcall;
  958. begin
  959.   try
  960.     enum := TEnumConnections.Create(FConnectionPoint, FIndex);
  961.     Result := S_OK;
  962.   except
  963.     Result := E_UNEXPECTED;
  964.   end;
  965. end;
  966.  
  967. { TConnectionPoint }
  968.  
  969. constructor TConnectionPoint.Create(Container: TConnectionPoints;
  970.   const IID: TGUID; OnConnect: TConnectEvent);
  971. begin
  972.   inherited Create(Container.Controller);
  973.   FContainer := Container;
  974.   FContainer.FConnectionPoints.Add(Self);
  975.   FIID := IID;
  976.   FOnConnect := OnConnect;
  977. end;
  978.  
  979. destructor TConnectionPoint.Destroy;
  980. begin
  981.   if FContainer <> nil then FContainer.FConnectionPoints.Remove(Self);
  982. end;
  983.  
  984. { TConnectionPoint.IConnectionPoint }
  985.  
  986. function TConnectionPoint.GetConnectionInterface(out iid: TIID): HResult;
  987. begin
  988.   iid := FIID;
  989.   Result := S_OK;
  990. end;
  991.  
  992. function TConnectionPoint.GetConnectionPointContainer(
  993.   out cpc: IConnectionPointContainer): HResult;
  994. begin
  995.   cpc := FContainer;
  996.   Result := S_OK;
  997. end;
  998.  
  999. function TConnectionPoint.Advise(const unkSink: IUnknown;
  1000.   out dwCookie: Longint): HResult;
  1001. begin
  1002.   if FSink <> nil then
  1003.   begin
  1004.     Result := CONNECT_E_CANNOTCONNECT;
  1005.     Exit;
  1006.   end;
  1007.   try
  1008.     if Assigned(FOnConnect) then FOnConnect(unkSink);
  1009.     FSink := unkSink;
  1010.     dwCookie := 1;
  1011.     Result := S_OK;
  1012.   except
  1013.     Result := HandleException;
  1014.   end;
  1015. end;
  1016.  
  1017. function TConnectionPoint.Unadvise(dwCookie: Longint): HResult;
  1018. begin
  1019.   if (FSink = nil) or (dwCookie <> 1) then
  1020.   begin
  1021.     Result := CONNECT_E_NOCONNECTION;
  1022.     Exit;
  1023.   end;
  1024.   try
  1025.     if Assigned(FOnConnect) then FOnConnect(nil);
  1026.     FSink := nil;
  1027.     Result := S_OK;
  1028.   except
  1029.     Result := HandleException;
  1030.   end;
  1031. end;
  1032.  
  1033. function TConnectionPoint.EnumConnections(
  1034.   out enum: IEnumConnections): HResult;
  1035. begin
  1036.   try
  1037.     enum := TEnumConnections.Create(Self, 0);
  1038.     Result := S_OK;
  1039.   except
  1040.     Result := HandleException;
  1041.   end;
  1042. end;
  1043.  
  1044. { TEnumConnectionPoints }
  1045.  
  1046. type
  1047.   TEnumConnectionPoints = class(TContainedObject, IEnumConnectionPoints)
  1048.   private
  1049.     FContainer: TConnectionPoints;
  1050.     FIndex: Integer;
  1051.   protected
  1052.     { IEnumConnectionPoints }
  1053.     function Next(celt: Longint; out elt;
  1054.       pceltFetched: PLongint): HResult; stdcall;
  1055.     function Skip(celt: Longint): HResult; stdcall;
  1056.     function Reset: HResult; stdcall;
  1057.     function Clone(out enum: IEnumConnectionPoints): HResult; stdcall;
  1058.   public
  1059.     constructor Create(Container: TConnectionPoints;
  1060.       Index: Integer);
  1061.   end;
  1062.  
  1063. constructor TEnumConnectionPoints.Create(Container: TConnectionPoints;
  1064.   Index: Integer);
  1065. begin
  1066.   inherited Create(Container.Controller);
  1067.   FContainer := Container;
  1068.   FIndex := Index;
  1069. end;
  1070.  
  1071. { TEnumConnectionPoints.IEnumConnectionPoints }
  1072.  
  1073. type
  1074.   TPointerList = array[0..0] of Pointer;
  1075.  
  1076. function TEnumConnectionPoints.Next(celt: Longint; out elt;
  1077.   pceltFetched: PLongint): HResult;
  1078. var
  1079.   I: Integer;
  1080.   P: Pointer;
  1081. begin
  1082.   I := 0;
  1083.   while (I < celt) and (FIndex < FContainer.FConnectionPoints.Count) do
  1084.   begin
  1085.     P := Pointer(IConnectionPoint(TConnectionPoint(
  1086.       FContainer.FConnectionPoints[FIndex])));
  1087.     IConnectionPoint(P)._AddRef;
  1088.     TPointerList(elt)[I] := P;
  1089.     Inc(I);
  1090.     Inc(FIndex);
  1091.   end;
  1092.   if pceltFetched <> nil then pceltFetched^ := I;
  1093.   if I = celt then Result := S_OK else Result := S_FALSE;
  1094. end;
  1095.  
  1096. function TEnumConnectionPoints.Skip(celt: Longint): HResult; stdcall;
  1097. begin
  1098.   if FIndex + celt <= FContainer.FConnectionPoints.Count then
  1099.   begin
  1100.     FIndex := FIndex + celt;
  1101.     Result := S_OK;
  1102.   end else
  1103.   begin
  1104.     FIndex := FContainer.FConnectionPoints.Count;
  1105.     Result := S_FALSE;
  1106.   end;
  1107. end;
  1108.  
  1109. function TEnumConnectionPoints.Reset: HResult; stdcall;
  1110. begin
  1111.   FIndex := 0;
  1112.   Result := S_OK;
  1113. end;
  1114.  
  1115. function TEnumConnectionPoints.Clone(
  1116.   out enum: IEnumConnectionPoints): HResult; stdcall;
  1117. begin
  1118.   try
  1119.     enum := TEnumConnectionPoints.Create(FContainer, FIndex);
  1120.     Result := S_OK;
  1121.   except
  1122.     Result := E_UNEXPECTED;
  1123.   end;
  1124. end;
  1125.  
  1126. { TConnectionPoints }
  1127.  
  1128. constructor TConnectionPoints.Create(const Controller: IUnknown);
  1129. begin
  1130.   inherited Create(Controller);
  1131.   FConnectionPoints := TList.Create;
  1132. end;
  1133.  
  1134. destructor TConnectionPoints.Destroy;
  1135. begin
  1136.   FreeObjectList(FConnectionPoints);
  1137. end;
  1138.  
  1139. function TConnectionPoints.CreateConnectionPoint(const IID: TGUID;
  1140.   OnConnect: TConnectEvent): TConnectionPoint;
  1141. begin
  1142.   Result := TConnectionPoint.Create(Self, IID, OnConnect);
  1143. end;
  1144.  
  1145. { TConnectionPoints.IConnectionPointContainer }
  1146.  
  1147. function TConnectionPoints.EnumConnectionPoints(
  1148.   out enum: IEnumConnectionPoints): HResult;
  1149. begin
  1150.   try
  1151.     enum := TEnumConnectionPoints.Create(Self, 0);
  1152.     Result := S_OK;
  1153.   except
  1154.     Result := E_UNEXPECTED;
  1155.   end;
  1156. end;
  1157.  
  1158. function TConnectionPoints.FindConnectionPoint(const iid: TIID;
  1159.   out cp: IConnectionPoint): HResult;
  1160. var
  1161.   I: Integer;
  1162.   ConnectionPoint: TConnectionPoint;
  1163. begin
  1164.   for I := 0 to FConnectionPoints.Count - 1 do
  1165.   begin
  1166.     ConnectionPoint := FConnectionPoints[I];
  1167.     if IsEqualGUID(ConnectionPoint.FIID, iid) then
  1168.     begin
  1169.       cp := ConnectionPoint;
  1170.       Result := S_OK;
  1171.       Exit;
  1172.     end;
  1173.   end;
  1174.   Result := CONNECT_E_NOCONNECTION;
  1175. end;
  1176.  
  1177. { TActiveXControl }
  1178.  
  1179. procedure TActiveXControl.Initialize;
  1180. begin
  1181.   FConnectionPoints := TConnectionPoints.Create(Self);
  1182.   FControlFactory := TActiveXControlFactory(Factory);
  1183.   if FControlFactory.FEventTypeInfo <> nil then
  1184.     FConnectionPoints.CreateConnectionPoint(FControlFactory.FEventIID,
  1185.       EventConnect);
  1186.   FControl := FControlFactory.WinControlClass.CreateParented(ParkingWindow);
  1187.   FControlWndProc := FControl.WindowProc;
  1188.   FControl.WindowProc := WndProc;
  1189.   InitializeControl;
  1190. end;
  1191.  
  1192. destructor TActiveXControl.Destroy;
  1193. begin
  1194.   if Assigned(FControlWndProc) then FControl.WindowProc := FControlWndProc;
  1195.   FControl.Free;
  1196.   FConnectionPoints.Free;
  1197.   inherited Destroy;
  1198. end;
  1199.  
  1200. function TActiveXControl.CreateAdviseHolder: HResult;
  1201. begin
  1202.   if FOleAdviseHolder = nil then
  1203.     Result := CreateOleAdviseHolder(FOleAdviseHolder) else
  1204.     Result := S_OK;
  1205. end;
  1206.  
  1207. procedure TActiveXControl.DefinePropertyPages(
  1208.   DefinePropertyPage: TDefinePropertyPage);
  1209. begin
  1210. end;
  1211.  
  1212. procedure TActiveXControl.EventConnect(const Sink: IUnknown);
  1213. begin
  1214.   if Sink <> nil then
  1215.     OleCheck(Sink.QueryInterface(FControlFactory.FEventIID, FEventSink)) else
  1216.     FEventSink := nil;
  1217.   EventSinkChanged(Sink);
  1218. end;
  1219.  
  1220. procedure TActiveXControl.EventSinkChanged(const EventSink: IUnknown);
  1221. begin
  1222. end;
  1223.  
  1224. function TActiveXControl.GetPropertyString(DispID: Integer;
  1225.   var S: string): Boolean;
  1226. begin
  1227.   Result := False;
  1228. end;
  1229.  
  1230. function TActiveXControl.GetPropertyStrings(DispID: Integer;
  1231.   Strings: TStrings): Boolean;
  1232. begin
  1233.   Result := False;
  1234. end;
  1235.  
  1236. procedure TActiveXControl.GetPropertyValue(DispID, Cookie: Integer;
  1237.   var Value: OleVariant);
  1238. begin
  1239. end;
  1240.  
  1241. procedure TActiveXControl.InitializeControl;
  1242. begin
  1243. end;
  1244.  
  1245. function TActiveXControl.InPlaceActivate(ActivateUI: Boolean): HResult;
  1246. var
  1247.   InPlaceActivateSent: Boolean;
  1248.   ParentWindow: HWND;
  1249.   PosRect, ClipRect: TRect;
  1250.   FrameInfo: TOleInPlaceFrameInfo;
  1251. begin
  1252.   Result := S_OK;
  1253.   FControl.Visible := True;
  1254.   InPlaceActivateSent := False;
  1255.   if not FInPlaceActive then
  1256.     try
  1257.       if FOleClientSite = nil then OleError(E_FAIL);
  1258.       OleCheck(FOleClientSite.QueryInterface(IOleInPlaceSite, FOleInPlaceSite));
  1259.       if FOleInPlaceSite.CanInPlaceActivate <> S_OK then OleError(E_FAIL);
  1260.       OleCheck(FOleInPlaceSite.OnInPlaceActivate);
  1261.       InPlaceActivateSent := True;
  1262.       OleCheck(FOleInPlaceSite.GetWindow(ParentWindow));
  1263.       FrameInfo.cb := SizeOf(FrameInfo);
  1264.       OleCheck(FOleInPlaceSite.GetWindowContext(FOleInPlaceFrame,
  1265.         FOleInPlaceUIWindow, PosRect, ClipRect, FrameInfo));
  1266.       if FOleInPlaceFrame = nil then OleError(E_FAIL);
  1267.       with PosRect do
  1268.         FControl.SetBounds(Left, Top, Right - Left, Bottom - Top);
  1269.       FControl.ParentWindow := ParentWindow;
  1270.       FInPlaceActive := True;
  1271.       FOleClientSite.ShowObject;
  1272.     except
  1273.       FInPlaceActive := False;
  1274.       FOleInPlaceUIWindow := nil;
  1275.       FOleInPlaceFrame := nil;
  1276.       if InPlaceActivateSent then FOleInPlaceSite.OnInPlaceDeactivate;
  1277.       FOleInPlaceSite := nil;
  1278.       Result := HandleException;
  1279.       Exit;
  1280.     end;
  1281.   if ActivateUI and not FUIActive then
  1282.   begin
  1283.     FUIActive := True;
  1284.     FOleInPlaceSite.OnUIActivate;
  1285.     SetFocus(FControl.Handle);
  1286.     FOleInPlaceFrame.SetActiveObject(Self, nil);
  1287.     if FOleInPlaceUIWindow <> nil then
  1288.       FOleInPlaceUIWindow.SetActiveObject(Self, nil);
  1289.     FOleInPlaceFrame.SetBorderSpace(nil);
  1290.     if FOleInPlaceUIWindow <> nil then
  1291.       FOleInPlaceUIWindow.SetBorderSpace(nil);
  1292.   end;
  1293. end;
  1294.  
  1295. procedure TActiveXControl.LoadFromStream(const Stream: IStream);
  1296. var
  1297.   OleStream: TOleStream;
  1298. begin
  1299.   OleStream := TOleStream.Create(Stream);
  1300.   try
  1301.     OleStream.ReadComponent(FControl);
  1302.   finally
  1303.     OleStream.Free;
  1304.   end;
  1305. end;
  1306.  
  1307. function TActiveXControl.ObjQueryInterface(const IID: TGUID; out Obj): Integer;
  1308. begin
  1309.   Result := inherited ObjQueryInterface(IID, Obj);
  1310.   if Result <> 0 then
  1311.     if FConnectionPoints.GetInterface(IID, Obj) then Result := S_OK;
  1312. end;
  1313.  
  1314. procedure TActiveXControl.PerformVerb(Verb: Integer);
  1315. begin
  1316. end;
  1317.  
  1318. procedure TActiveXControl.RecreateWnd;
  1319. var
  1320.   WasUIActive: Boolean;
  1321.   PrevWnd: HWND;
  1322. begin
  1323.   if FControl.HandleAllocated then
  1324.   begin
  1325.     WasUIActive := FUIActive;
  1326.     PrevWnd := Windows.GetWindow(FControl.Handle, GW_HWNDPREV);
  1327.     InPlaceDeactivate;
  1328.     if InPlaceActivate(WasUIActive) = S_OK then
  1329.       SetWindowPos(FControl.Handle, PrevWnd, 0, 0, 0, 0,
  1330.         SWP_NOSIZE or SWP_NOMOVE or SWP_NOACTIVATE);
  1331.   end;
  1332. end;
  1333.  
  1334. procedure TActiveXControl.SaveToStream(const Stream: IStream);
  1335. var
  1336.   OleStream: TOleStream;
  1337.   Writer: TWriter;
  1338. begin
  1339.   OleStream := TOleStream.Create(Stream);
  1340.   try
  1341.     Writer := TWriter.Create(OleStream, 4096);
  1342.     try
  1343.       Writer.IgnoreChildren := True;
  1344.       Writer.WriteDescendent(FControl, nil);
  1345.     finally
  1346.       Writer.Free;
  1347.     end;
  1348.   finally
  1349.     OleStream.Free;
  1350.   end;
  1351. end;
  1352.  
  1353. procedure TActiveXControl.ShowPropertyDialog;
  1354. var
  1355.   Unknown: IUnknown;
  1356.   Pages: TCAGUID;
  1357. begin
  1358.   if (FOleControlSite <> nil) and
  1359.     (FOleControlSite.ShowPropertyFrame = S_OK) then Exit;
  1360.   OleCheck(GetPages(Pages));
  1361.   try
  1362.     if Pages.cElems > 0 then
  1363.     begin
  1364.       if FOleInPlaceFrame <> nil then
  1365.         FOleInPlaceFrame.EnableModeless(False);
  1366.       try
  1367.         Unknown := Self;
  1368.         OleCheck(OleCreatePropertyFrame(GetActiveWindow, 16, 16,
  1369.           PWideChar(FAmbientDispatch.DisplayName), {!!!}
  1370.           1, @Unknown, Pages.cElems, Pages.pElems,
  1371.           GetSystemDefaultLCID, 0, nil));
  1372.       finally
  1373.         if FOleInPlaceFrame <> nil then
  1374.           FOleInPlaceFrame.EnableModeless(True);
  1375.       end;
  1376.     end;
  1377.   finally
  1378.     CoFreeMem(pages.pElems);
  1379.   end;
  1380. end;
  1381.  
  1382. procedure TActiveXControl.StdClickEvent(Sender: TObject);
  1383. begin
  1384.   if FEventSink <> nil then IStdEvents(FEventSink).Click;
  1385. end;
  1386.  
  1387. procedure TActiveXControl.StdDblClickEvent(Sender: TObject);
  1388. begin
  1389.   if FEventSink <> nil then IStdEvents(FEventSink).DblClick;
  1390. end;
  1391.  
  1392. procedure TActiveXControl.StdKeyDownEvent(Sender: TObject; var Key: Word;
  1393.   Shift: TShiftState);
  1394. begin
  1395.   if FEventSink <> nil then
  1396.     IStdEvents(FEventSink).KeyDown(Smallint(Key), GetEventShift(Shift));
  1397. end;
  1398.  
  1399. procedure TActiveXControl.StdKeyPressEvent(Sender: TObject; var Key: Char);
  1400. var
  1401.   KeyAscii: Smallint;
  1402. begin
  1403.   if FEventSink <> nil then
  1404.   begin
  1405.     KeyAscii := Ord(Key);
  1406.     IStdEvents(FEventSink).KeyPress(KeyAscii);
  1407.     Key := Chr(KeyAscii);
  1408.   end;
  1409. end;
  1410.  
  1411. procedure TActiveXControl.StdKeyUpEvent(Sender: TObject; var Key: Word;
  1412.   Shift: TShiftState);
  1413. begin
  1414.   if FEventSink <> nil then
  1415.     IStdEvents(FEventSink).KeyUp(Smallint(Key), GetEventShift(Shift));
  1416. end;
  1417.  
  1418. procedure TActiveXControl.StdMouseDownEvent(Sender: TObject;
  1419.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  1420. begin
  1421.   if FEventSink <> nil then
  1422.     IStdEvents(FEventSink).MouseDown(GetEventButton(Button),
  1423.       GetEventShift(Shift), X, Y);
  1424. end;
  1425.  
  1426. procedure TActiveXControl.StdMouseMoveEvent(Sender: TObject;
  1427.   Shift: TShiftState; X, Y: Integer);
  1428. begin
  1429.   if FEventSink <> nil then
  1430.     IStdEvents(FEventSink).MouseMove((Byte(Shift) shr 3) and 7,
  1431.       GetEventShift(Shift), X, Y);
  1432. end;
  1433.  
  1434. procedure TActiveXControl.StdMouseUpEvent(Sender: TObject;
  1435.   Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  1436. begin
  1437.   if FEventSink <> nil then
  1438.     IStdEvents(FEventSink).MouseUp(GetEventButton(Button),
  1439.       GetEventShift(Shift), X, Y);
  1440. end;
  1441.  
  1442. procedure TActiveXControl.ViewChanged;
  1443. begin
  1444.   if FAdviseSink <> nil then
  1445.   begin
  1446.     FAdviseSink.OnViewChange(DVASPECT_CONTENT, -1);
  1447.     if FAdviseFlags and ADVF_ONLYONCE <> 0 then FAdviseSink := nil;
  1448.   end;
  1449. end;
  1450.  
  1451. procedure TActiveXControl.WndProc(var Message: TMessage);
  1452. var
  1453.   Handle: HWnd;
  1454.   FilterMessage: Boolean;
  1455.   Cookie: Longint;
  1456.  
  1457.   procedure ControlWndProc;
  1458.   begin
  1459.     with Message do
  1460.       if (Msg >= OCM_BASE) and (Msg < OCM_BASE + WM_USER) then
  1461.         Msg := Msg + (CN_BASE - OCM_BASE);
  1462.     FControlWndProc(Message);
  1463.     with Message do
  1464.       if (Msg >= CN_BASE) and (Msg < CN_BASE + WM_USER) then
  1465.         Msg := Msg - (CN_BASE - OCM_BASE);
  1466.   end;
  1467.  
  1468. begin
  1469.   with Message do
  1470.   begin
  1471.     Handle := TWinControlAccess(FControl).WindowHandle;
  1472.     FilterMessage := (Msg < CM_BASE) and (FSimpleFrameSite <> nil) and
  1473.       FInPlaceActive;
  1474.     if FilterMessage then
  1475.       if FSimpleFrameSite.PreMessageFilter(Handle, Msg, WParam, LParam,
  1476.         Integer(Result), Cookie) = S_FALSE then Exit;
  1477.     case Msg of
  1478.       WM_SETFOCUS, WM_KILLFOCUS:
  1479.         begin
  1480.           ControlWndProc;
  1481.           if FOleControlSite <> nil then
  1482.             FOleControlSite.OnFocus(Msg = WM_SETFOCUS);
  1483.         end;
  1484.       CM_VISIBLECHANGED:
  1485.         begin
  1486.           if not FControl.Visible then UIDeactivate;
  1487.           ControlWndProc;
  1488.         end;
  1489.       CM_RECREATEWND:
  1490.         if FInPlaceActive then
  1491.           RecreateWnd
  1492.         else
  1493.         begin
  1494.           ControlWndProc;
  1495.           ViewChanged;
  1496.         end;
  1497.       CM_INVALIDATE,
  1498.       WM_SETTEXT:
  1499.         begin
  1500.           ControlWndProc;
  1501.           if not FInPlaceActive then ViewChanged;
  1502.         end;
  1503.     else
  1504.       ControlWndProc;
  1505.     end;
  1506.     if FilterMessage then
  1507.       FSimpleFrameSite.PostMessageFilter(Handle, Msg, WParam, LParam,
  1508.         Integer(Result), Cookie);
  1509.   end;
  1510. end;
  1511.  
  1512. { TActiveXControl standard properties }
  1513.  
  1514. function TActiveXControl.Get_BackColor: Integer;
  1515. begin
  1516.   Result := TWinControlAccess(FControl).Color;
  1517. end;
  1518.  
  1519. function TActiveXControl.Get_Caption: WideString;
  1520. begin
  1521.   Result := TWinControlAccess(FControl).Caption;
  1522. end;
  1523.  
  1524. function TActiveXControl.Get_Enabled: WordBool;
  1525. begin
  1526.   Result := FControl.Enabled;
  1527. end;
  1528.  
  1529. function TActiveXControl.Get_Font: Font;
  1530. begin
  1531.   GetOleFont(TWinControlAccess(FControl).Font, Result);
  1532. end;
  1533.  
  1534. function TActiveXControl.Get_ForeColor: Integer;
  1535. begin
  1536.   Result := TWinControlAccess(FControl).Font.Color;
  1537. end;
  1538.  
  1539. function TActiveXControl.Get_HWnd: Integer;
  1540. begin
  1541.   Result := FControl.Handle;
  1542. end;
  1543.  
  1544. function TActiveXControl.Get_TabStop: WordBool;
  1545. begin
  1546.   Result := FControl.TabStop;
  1547. end;
  1548.  
  1549. function TActiveXControl.Get_Text: WideString;
  1550. begin
  1551.   Result := TWinControlAccess(FControl).Text;
  1552. end;
  1553.  
  1554. procedure TActiveXControl.Set_BackColor(Value: Integer);
  1555. begin
  1556.   TWinControlAccess(FControl).Color := Value;
  1557. end;
  1558.  
  1559. procedure TActiveXControl.Set_Caption(const Value: WideString);
  1560. begin
  1561.   TWinControlAccess(FControl).Caption := Value;
  1562. end;
  1563.  
  1564. procedure TActiveXControl.Set_Enabled(Value: WordBool);
  1565. begin
  1566.   FControl.Enabled := Value;
  1567. end;
  1568.  
  1569. procedure TActiveXControl.Set_Font(const Value: Font);
  1570. begin
  1571.   SetOleFont(TWinControlAccess(FControl).Font, Value);
  1572. end;
  1573.  
  1574. procedure TActiveXControl.Set_ForeColor(Value: Integer);
  1575. begin
  1576.   TWinControlAccess(FControl).Font.Color := Value;
  1577. end;
  1578.  
  1579. procedure TActiveXControl.Set_TabStop(Value: WordBool);
  1580. begin
  1581.   FControl.TabStop := Value;
  1582. end;
  1583.  
  1584. procedure TActiveXControl.Set_Text(const Value: WideString);
  1585. begin
  1586.   TWinControlAccess(FControl).Text := Value;
  1587. end;
  1588.  
  1589. { TActiveXControl.IPersist }
  1590.  
  1591. function TActiveXControl.GetClassID(out classID: TCLSID): HResult;
  1592. begin
  1593.   classID := Factory.ClassID;
  1594.   Result := S_OK;
  1595. end;
  1596.  
  1597. { TActiveXControl.IPersistStreamInit }
  1598.  
  1599. function TActiveXControl.IsDirty: HResult;
  1600. begin
  1601.   if FIsDirty then Result := S_OK else Result := S_FALSE;
  1602. end;
  1603.  
  1604. function TActiveXControl.PersistStreamLoad(const stm: IStream): HResult;
  1605. begin
  1606.   try
  1607.     LoadFromStream(stm);
  1608.     FIsDirty := False;
  1609.     Result := S_OK;
  1610.   except
  1611.     Result := HandleException;
  1612.   end;
  1613. end;
  1614.  
  1615. function TActiveXControl.PersistStreamSave(const stm: IStream;
  1616.   fClearDirty: BOOL): HResult;
  1617. begin
  1618.   try
  1619.     SaveToStream(stm);
  1620.     if fClearDirty then FIsDirty := False;
  1621.     Result := S_OK;
  1622.   except
  1623.     Result := HandleException;
  1624.   end;
  1625. end;
  1626.  
  1627. function TActiveXControl.GetSizeMax(out cbSize: Largeint): HResult;
  1628. begin
  1629.   Result := E_NOTIMPL;
  1630. end;
  1631.  
  1632. function TActiveXControl.InitNew: HResult;
  1633. begin
  1634.   try
  1635.     FIsDirty := False;
  1636.     Result := S_OK;
  1637.   except
  1638.     Result := HandleException;
  1639.   end;
  1640. end;
  1641.  
  1642. { TActiveXControl.IPersistStorage }
  1643.  
  1644. function TActiveXControl.PersistStorageInitNew(const stg: IStorage): HResult;
  1645. begin
  1646.   Result := InitNew;
  1647. end;
  1648.  
  1649. function TActiveXControl.PersistStorageLoad(const stg: IStorage): HResult;
  1650. var
  1651.   Stream: IStream;
  1652. begin
  1653.   try
  1654.     OleCheck(stg.OpenStream('CONTROLSAVESTREAM'#0, nil, STGM_READ +
  1655.       STGM_SHARE_EXCLUSIVE, 0, Stream));
  1656.     LoadFromStream(Stream);
  1657.     FIsDirty := False;
  1658.     Result := S_OK;
  1659.   except
  1660.     Result := HandleException;
  1661.   end;
  1662. end;
  1663.  
  1664. function TActiveXControl.PersistStorageSave(const stgSave: IStorage;
  1665.   fSameAsLoad: BOOL): HResult;
  1666. var
  1667.   Stream: IStream;
  1668. begin
  1669.   try
  1670.     OleCheck(stgSave.CreateStream('CONTROLSAVESTREAM'#0, STGM_WRITE +
  1671.       STGM_SHARE_EXCLUSIVE + STGM_CREATE, 0, 0, Stream));
  1672.     SaveToStream(Stream);
  1673.     Result := S_OK;
  1674.   except
  1675.     Result := HandleException;
  1676.   end;
  1677. end;
  1678.  
  1679. function TActiveXControl.SaveCompleted(const stgNew: IStorage): HResult;
  1680. begin
  1681.   FIsDirty := False;
  1682.   Result := S_OK;
  1683. end;
  1684.  
  1685. function TActiveXControl.HandsOffStorage: HResult;
  1686. begin
  1687.   Result := S_OK;
  1688. end;
  1689.  
  1690. { TActiveXControl.IOleObject }
  1691.  
  1692. function TActiveXControl.SetClientSite(const ClientSite: IOleClientSite): HResult;
  1693. begin
  1694.   if ClientSite <> nil then
  1695.   begin
  1696.     if FOleClientSite <> nil then
  1697.     begin
  1698.       Result := E_FAIL;
  1699.       Exit;
  1700.     end;
  1701.     FOleClientSite := ClientSite;
  1702.     ClientSite.QueryInterface(IOleControlSite, FOleControlSite);
  1703.     if FControlFactory.FMiscStatus and OLEMISC_SIMPLEFRAME <> 0 then
  1704.       ClientSite.QueryInterface(ISimpleFrameSite, FSimpleFrameSite);
  1705.     ClientSite.QueryInterface(IDispatch, FAmbientDispatch);
  1706.   end else
  1707.   begin
  1708.     FAmbientDispatch := nil;
  1709.     FSimpleFrameSite := nil;
  1710.     FOleControlSite := nil;
  1711.     FOleClientSite := nil;
  1712.   end;
  1713.   Result := S_OK;
  1714. end;
  1715.  
  1716. function TActiveXControl.GetClientSite(out clientSite: IOleClientSite): HResult;
  1717. begin
  1718.   ClientSite := FOleClientSite;
  1719.   Result := S_OK;
  1720. end;
  1721.  
  1722. function TActiveXControl.SetHostNames(szContainerApp: POleStr;
  1723.   szContainerObj: POleStr): HResult;
  1724. begin
  1725.   Result := S_OK;
  1726. end;
  1727.  
  1728. function TActiveXControl.Close(dwSaveOption: Longint): HResult;
  1729. begin
  1730.   if (dwSaveOption <> OLECLOSE_NOSAVE) and FIsDirty and
  1731.     (FOleClientSite <> nil) then FOleClientSite.SaveObject;
  1732.   Result := InPlaceDeactivate;
  1733. end;
  1734.  
  1735. function TActiveXControl.SetMoniker(dwWhichMoniker: Longint; const mk: IMoniker): HResult;
  1736. begin
  1737.   Result := E_NOTIMPL;
  1738. end;
  1739.  
  1740. function TActiveXControl.GetMoniker(dwAssign: Longint; dwWhichMoniker: Longint;
  1741.   out mk: IMoniker): HResult;
  1742. begin
  1743.   Result := E_NOTIMPL;
  1744. end;
  1745.  
  1746. function TActiveXControl.InitFromData(const dataObject: IDataObject; fCreation: BOOL;
  1747.   dwReserved: Longint): HResult;
  1748. begin
  1749.   Result := E_NOTIMPL;
  1750. end;
  1751.  
  1752. function TActiveXControl.GetClipboardData(dwReserved: Longint;
  1753.   out dataObject: IDataObject): HResult;
  1754. begin
  1755.   Result := E_NOTIMPL;
  1756. end;
  1757.  
  1758. function TActiveXControl.DoVerb(iVerb: Longint; msg: PMsg; const activeSite: IOleClientSite;
  1759.   lindex: Longint; hwndParent: HWND; const posRect: TRect): HResult;
  1760. begin
  1761.   try
  1762.     case iVerb of
  1763.       OLEIVERB_SHOW,
  1764.       OLEIVERB_UIACTIVATE:
  1765.         Result := InPlaceActivate(True);
  1766.       OLEIVERB_INPLACEACTIVATE:
  1767.         Result := InPlaceActivate(False);
  1768.       OLEIVERB_HIDE:
  1769.         begin
  1770.           FControl.Visible := False;
  1771.           Result := S_OK;
  1772.         end;
  1773.       OLEIVERB_PRIMARY,
  1774.       OLEIVERB_PROPERTIES:
  1775.         begin
  1776.           ShowPropertyDialog;
  1777.           Result := S_OK;
  1778.         end;
  1779.     else
  1780.       if FControlFactory.FVerbs.IndexOfObject(TObject(iVerb)) >= 0 then
  1781.       begin
  1782.         PerformVerb(iVerb);
  1783.         Result := S_OK;
  1784.       end else
  1785.         Result := OLEOBJ_S_INVALIDVERB;
  1786.     end;
  1787.   except
  1788.     Result := HandleException;
  1789.   end;
  1790. end;
  1791.  
  1792. function TActiveXControl.EnumVerbs(out enumOleVerb: IEnumOleVerb): HResult;
  1793. begin
  1794.   Result := OleRegEnumVerbs(Factory.ClassID, enumOleVerb);
  1795. end;
  1796.  
  1797. function TActiveXControl.Update: HResult;
  1798. begin
  1799.   Result := S_OK;
  1800. end;
  1801.  
  1802. function TActiveXControl.IsUpToDate: HResult;
  1803. begin
  1804.   Result := S_OK;
  1805. end;
  1806.  
  1807. function TActiveXControl.GetUserClassID(out clsid: TCLSID): HResult;
  1808. begin
  1809.   clsid := Factory.ClassID;
  1810.   Result := S_OK;
  1811. end;
  1812.  
  1813. function TActiveXControl.GetUserType(dwFormOfType: Longint; out pszUserType: POleStr): HResult;
  1814. begin
  1815.   Result := OleRegGetUserType(Factory.ClassID, dwFormOfType, pszUserType);
  1816. end;
  1817.  
  1818. function TActiveXControl.SetExtent(dwDrawAspect: Longint; const size: TPoint): HResult;
  1819. var
  1820.   W, H: Integer;
  1821. begin
  1822.   try
  1823.     if dwDrawAspect <> DVASPECT_CONTENT then OleError(DV_E_DVASPECT);
  1824.     W := MulDiv(Size.X, Screen.PixelsPerInch, 2540);
  1825.     H := MulDiv(Size.Y, Screen.PixelsPerInch, 2540);
  1826.     with FControl do SetBounds(Left, Top, W, H);
  1827.     Result := S_OK;
  1828.   except
  1829.     Result := HandleException;
  1830.   end;
  1831. end;
  1832.  
  1833. function TActiveXControl.GetExtent(dwDrawAspect: Longint; out size: TPoint): HResult;
  1834. begin
  1835.   if dwDrawAspect <> DVASPECT_CONTENT then
  1836.   begin
  1837.     Result := DV_E_DVASPECT;
  1838.     Exit;
  1839.   end;
  1840.   Size.X := MulDiv(FControl.Width, 2540, Screen.PixelsPerInch);
  1841.   Size.Y := MulDiv(FControl.Height, 2540, Screen.PixelsPerInch);
  1842.   Result := S_OK;
  1843. end;
  1844.  
  1845. function TActiveXControl.Advise(const advSink: IAdviseSink; out dwConnection: Longint): HResult;
  1846. begin
  1847.   Result := CreateAdviseHolder;
  1848.   if Result = S_OK then
  1849.     Result := FOleAdviseHolder.Advise(advSink, dwConnection);
  1850. end;
  1851.  
  1852. function TActiveXControl.Unadvise(dwConnection: Longint): HResult;
  1853. begin
  1854.   Result := CreateAdviseHolder;
  1855.   if Result = S_OK then
  1856.     Result := FOleAdviseHolder.Unadvise(dwConnection);
  1857. end;
  1858.  
  1859. function TActiveXControl.EnumAdvise(out enumAdvise: IEnumStatData): HResult;
  1860. begin
  1861.   Result := CreateAdviseHolder;
  1862.   if Result = S_OK then
  1863.     Result := FOleAdviseHolder.EnumAdvise(enumAdvise);
  1864. end;
  1865.  
  1866. function TActiveXControl.GetMiscStatus(dwAspect: Longint; out dwStatus: Longint): HResult;
  1867. begin
  1868.   if dwAspect <> DVASPECT_CONTENT then
  1869.   begin
  1870.     Result := DV_E_DVASPECT;
  1871.     Exit;
  1872.   end;
  1873.   dwStatus := FControlFactory.FMiscStatus;
  1874.   Result := S_OK;
  1875. end;
  1876.  
  1877. function TActiveXControl.SetColorScheme(const logpal: TLogPalette): HResult;
  1878. begin
  1879.   Result := E_NOTIMPL;
  1880. end;
  1881.  
  1882. { TActiveXControl.IOleControl }
  1883.  
  1884. function TActiveXControl.GetControlInfo(var ci: TControlInfo): HResult;
  1885. begin
  1886.   Result := E_NOTIMPL; {!!!}
  1887. end;
  1888.  
  1889. function TActiveXControl.OnMnemonic(msg: PMsg): HResult;
  1890. begin
  1891.   Result := InPlaceActivate(True);
  1892. end;
  1893.  
  1894. function TActiveXControl.OnAmbientPropertyChange(dispid: TDispID): HResult;
  1895. begin
  1896.   Result := S_OK; {!!!}
  1897. end;
  1898.  
  1899. function TActiveXControl.FreezeEvents(bFreeze: BOOL): HResult;
  1900. begin
  1901.   FEventsFrozen := bFreeze;
  1902.   Result := S_OK;
  1903. end;
  1904.  
  1905. { TActiveXControl.IOleWindow }
  1906.  
  1907. function TActiveXControl.GetWindow(out wnd: HWnd): HResult;
  1908. begin
  1909.   if FControl.HandleAllocated then
  1910.   begin
  1911.     wnd := FControl.Handle;
  1912.     Result := S_OK;
  1913.   end else
  1914.     Result := E_FAIL;
  1915. end;
  1916.  
  1917. function TActiveXControl.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
  1918. begin
  1919.   Result := E_NOTIMPL;
  1920. end;
  1921.  
  1922. { TActiveXControl.IOleInPlaceObject }
  1923.  
  1924. function TActiveXControl.InPlaceDeactivate: HResult;
  1925. begin
  1926.   if FInPlaceActive then
  1927.   begin
  1928.     UIDeactivate;
  1929.     FInPlaceActive := False;
  1930.     FControl.ParentWindow := ParkingWindow;
  1931.     FOleInPlaceUIWindow := nil;
  1932.     FOleInPlaceFrame := nil;
  1933.     FOleInPlaceSite.OnInPlaceDeactivate;
  1934.     FOleInPlaceSite := nil;
  1935.   end;
  1936.   FControl.Visible := False;
  1937.   Result := S_OK;
  1938. end;
  1939.  
  1940. function TActiveXControl.UIDeactivate: HResult;
  1941. begin
  1942.   if FUIActive then
  1943.   begin
  1944.     if FOleInPlaceUIWindow <> nil then
  1945.       FOleInPlaceUIWindow.SetActiveObject(nil, nil);
  1946.     FOleInPlaceFrame.SetActiveObject(nil, nil);
  1947.     FOleInPlaceSite.OnUIDeactivate(False);
  1948.     FUIActive := False;
  1949.   end;
  1950.   Result := S_OK;
  1951. end;
  1952.  
  1953. function TActiveXControl.SetObjectRects(const rcPosRect: TRect;
  1954.   const rcClipRect: TRect): HResult;
  1955. begin
  1956.   try
  1957.     FControl.BoundsRect := rcPosRect;
  1958.     Result := S_OK;
  1959.   except
  1960.     Result := HandleException;
  1961.   end;
  1962. end;
  1963.  
  1964. function TActiveXControl.ReactivateAndUndo: HResult;
  1965. begin
  1966.   Result := E_NOTIMPL;
  1967. end;
  1968.  
  1969. { TActiveXControl.IOleInPlaceActiveObject }
  1970.  
  1971. function TActiveXControl.TranslateAccelerator(var msg: TMsg): HResult;
  1972. begin
  1973.   with Msg do
  1974.     if (Message >= WM_KEYFIRST) and (Message <= WM_KEYLAST)
  1975.      and (Pt.X <> $115DE1F1) and (Pt.Y <> $115DE1F1) then
  1976.       if SendMessage(HWnd, CN_BASE + Message, WParam, LParam) <> 0 then
  1977.       begin
  1978.         Result := S_OK;
  1979.         Exit;
  1980.       end;
  1981.   if FOleControlSite <> nil then
  1982.     Result := FOleControlSite.TranslateAccelerator(@msg, GetKeyModifiers)
  1983.   else
  1984.     Result := S_FALSE;
  1985. end;
  1986.  
  1987. function TActiveXControl.OnFrameWindowActivate(fActivate: BOOL): HResult;
  1988. begin
  1989.   Result := InPlaceActivate(True);
  1990. end;
  1991.  
  1992. function TActiveXControl.OnDocWindowActivate(fActivate: BOOL): HResult;
  1993. begin
  1994.   Result := InPlaceActivate(True);
  1995. end;
  1996.  
  1997. function TActiveXControl.ResizeBorder(const rcBorder: TRect; const uiWindow: IOleInPlaceUIWindow;
  1998.   fFrameWindow: BOOL): HResult;
  1999. begin
  2000.   Result := S_OK;
  2001. end;
  2002.  
  2003. function TActiveXControl.EnableModeless(fEnable: BOOL): HResult;
  2004. begin
  2005.   Result := S_OK;
  2006. end;
  2007.  
  2008. { TActiveXControl.IViewObject }
  2009.  
  2010. function TActiveXControl.Draw(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  2011.   ptd: PDVTargetDevice; hicTargetDev: HDC; hdcDraw: HDC;
  2012.   prcBounds: PRect; prcWBounds: PRect; fnContinue: TContinueFunc;
  2013.   dwContinue: Longint): HResult;
  2014. var
  2015.   R: TRect;
  2016.   SaveIndex: Integer;
  2017.   WasVisible: Boolean;
  2018. begin
  2019.   try
  2020.     if dwDrawAspect <> DVASPECT_CONTENT then OleError(DV_E_DVASPECT);
  2021.     WasVisible := FControl.Visible;
  2022.     try
  2023.       FControl.Visible := True;
  2024.       ShowWindow(FControl.Handle, 1);
  2025.       R := prcBounds^;
  2026.       LPToDP(hdcDraw, R, 2);
  2027.       SaveIndex := SaveDC(hdcDraw);
  2028.       try
  2029.         SetViewportOrgEx(hdcDraw, 0, 0, nil);
  2030.         SetWindowOrgEx(hdcDraw, 0, 0, nil);
  2031.         SetMapMode(hdcDraw, MM_TEXT);
  2032.         FControl.PaintTo(hdcDraw, R.Left, R.Top);
  2033.       finally
  2034.         RestoreDC(hdcDraw, SaveIndex);
  2035.       end;
  2036.     finally
  2037.       FControl.Visible := WasVisible;
  2038.     end;
  2039.     Result := S_OK;
  2040.   except
  2041.     Result := HandleException;
  2042.   end;
  2043. end;
  2044.  
  2045. function TActiveXControl.GetColorSet(dwDrawAspect: Longint; lindex: Longint;
  2046.   pvAspect: Pointer; ptd: PDVTargetDevice; hicTargetDev: HDC;
  2047.   out colorSet: PLogPalette): HResult;
  2048. begin
  2049.   Result := E_NOTIMPL;
  2050. end;
  2051.  
  2052. function TActiveXControl.Freeze(dwDrawAspect: Longint; lindex: Longint; pvAspect: Pointer;
  2053.   out dwFreeze: Longint): HResult;
  2054. begin
  2055.   Result := E_NOTIMPL;
  2056. end;
  2057.  
  2058. function TActiveXControl.Unfreeze(dwFreeze: Longint): HResult;
  2059. begin
  2060.   Result := E_NOTIMPL;
  2061. end;
  2062.  
  2063. function TActiveXControl.SetAdvise(aspects: Longint; advf: Longint;
  2064.   const advSink: IAdviseSink): HResult;
  2065. begin
  2066.   if aspects and DVASPECT_CONTENT = 0 then
  2067.   begin
  2068.     Result := DV_E_DVASPECT;
  2069.     Exit;
  2070.   end;
  2071.   FAdviseFlags := advf;
  2072.   FAdviseSink := advSink;
  2073.   if FAdviseFlags and ADVF_PRIMEFIRST <> 0 then ViewChanged;
  2074.   Result := S_OK;
  2075. end;
  2076.  
  2077. function TActiveXControl.GetAdvise(pAspects: PLongint; pAdvf: PLongint;
  2078.   out advSink: IAdviseSink): HResult;
  2079. begin
  2080.   if pAspects <> nil then pAspects^ := DVASPECT_CONTENT;
  2081.   if pAdvf <> nil then pAdvf^ := FAdviseFlags;
  2082.   if @advSink <> nil then advSink := FAdviseSink;
  2083.   Result := S_OK;
  2084. end;
  2085.  
  2086. { TActiveXControl.IViewObject2 }
  2087.  
  2088. function TActiveXControl.ViewObjectGetExtent(dwDrawAspect: Longint; lindex: Longint;
  2089.   ptd: PDVTargetDevice; out size: TPoint): HResult;
  2090. begin
  2091.   Result := GetExtent(dwDrawAspect, size);
  2092. end;
  2093.  
  2094. { TActiveXControl.IPerPropertyBrowsing }
  2095.  
  2096. function TActiveXControl.GetDisplayString(dispid: TDispID;
  2097.   pbstr: PWideString): HResult;
  2098. begin
  2099.   Result := E_NOTIMPL;
  2100. end;
  2101.  
  2102. function TActiveXControl.MapPropertyToPage(dispid: TDispID;
  2103.   out clsid: TCLSID): HResult;
  2104. begin
  2105.   if @clsid <> nil then clsid := GUID_NULL;
  2106.   Result := E_NOTIMPL; {!!!}
  2107. end;
  2108.  
  2109. function TActiveXControl.GetPredefinedStrings(dispid: TDispID;
  2110.   out caStringsOut: TCAPOleStr; out caCookiesOut: TCALongint): HResult;
  2111. var
  2112.   StringList: POleStrList;
  2113.   CookieList: PLongintList;
  2114.   Strings: TStringList;
  2115.   Count, I: Integer;
  2116. begin
  2117.   StringList := nil;
  2118.   CookieList := nil;
  2119.   Count := 0;
  2120.   try
  2121.     Strings := TStringList.Create;
  2122.     try
  2123.       if GetPropertyStrings(dispid, Strings) then
  2124.       begin
  2125.         Count := Strings.Count;
  2126.         StringList := CoAllocMem(Count * SizeOf(Pointer));
  2127.         CookieList := CoAllocMem(Count * SizeOf(Longint));
  2128.         for I := 0 to Count - 1 do
  2129.         begin
  2130.           StringList[I] := CoAllocString(Strings[I]);
  2131.           CookieList[I] := Longint(Strings.Objects[I]);
  2132.         end;
  2133.         caStringsOut.cElems := Count;
  2134.         caStringsOut.pElems := StringList;
  2135.         caCookiesOut.cElems := Count;
  2136.         caCookiesOut.pElems := CookieList;
  2137.         Result := S_OK;
  2138.       end else
  2139.         Result := E_NOTIMPL;
  2140.     finally
  2141.       Strings.Free;
  2142.     end;
  2143.   except
  2144.     if StringList <> nil then
  2145.       for I := 0 to Count - 1 do CoFreeMem(StringList[I]);
  2146.     CoFreeMem(CookieList);
  2147.     CoFreeMem(StringList);
  2148.     Result := HandleException;
  2149.   end;
  2150. end;
  2151.  
  2152. function TActiveXControl.GetPredefinedValue(dispid: TDispID;
  2153.   dwCookie: Longint; out varOut: Variant): HResult;
  2154. var
  2155.   Temp: OleVariant;
  2156. begin
  2157.   GetPropertyValue(dispid, dwCookie, Temp);
  2158.   varOut := Temp;
  2159.   Result := S_OK;
  2160. end;
  2161.  
  2162. { TActiveXControl.ISpecifyPropertyPages }
  2163.  
  2164. type
  2165.   TPropPages = class
  2166.   private
  2167.     FGUIDList: PGUIDList;
  2168.     FCount: Integer;
  2169.     procedure ProcessPage(const GUID: TGUID);
  2170.   end;
  2171.  
  2172. procedure TPropPages.ProcessPage(const GUID: TGUID);
  2173. begin
  2174.   if FGUIDList <> nil then FGUIDList[FCount] := GUID;
  2175.   Inc(FCount);
  2176. end;
  2177.  
  2178. function TActiveXControl.GetPages(out pages: TCAGUID): HResult;
  2179. var
  2180.   PropPages: TPropPages;
  2181. begin
  2182.   try
  2183.     PropPages := TPropPages.Create;
  2184.     try
  2185.       DefinePropertyPages(PropPages.ProcessPage);
  2186.       PropPages.FGUIDList := CoAllocMem(PropPages.FCount * SizeOf(TGUID));
  2187.       PropPages.FCount := 0;
  2188.       DefinePropertyPages(PropPages.ProcessPage);
  2189.       pages.cElems := PropPages.FCount;
  2190.       pages.pElems := PropPages.FGUIDList;
  2191.       PropPages.FGUIDList := nil;
  2192.     finally
  2193.       if PropPages.FGUIDList <> nil then CoFreeMem(PropPages.FGUIDList);
  2194.       PropPages.Free;
  2195.     end;
  2196.     Result := S_OK;
  2197.   except
  2198.     Result := HandleException;
  2199.   end;
  2200. end;
  2201.  
  2202. { TActiveXControlFactory }
  2203.  
  2204. constructor TActiveXControlFactory.Create(ComServer: TComServerObject;
  2205.   ActiveXControlClass: TActiveXControlClass;
  2206.   WinControlClass: TWinControlClass; const ClassID: TGUID;
  2207.   ToolboxBitmapID: Integer; const LicStr: string);
  2208. var
  2209.   TypeAttr: PTypeAttr;
  2210. begin
  2211.   FWinControlClass := WinControlClass;
  2212.   inherited Create(ComServer, ActiveXControlClass, ClassID, ciMultiInstance);
  2213.   {!!!} { Support additional flags }
  2214.   FMiscStatus :=
  2215.     OLEMISC_RECOMPOSEONRESIZE +
  2216.     OLEMISC_CANTLINKINSIDE +
  2217.     OLEMISC_INSIDEOUT +
  2218.     OLEMISC_ACTIVATEWHENVISIBLE +
  2219.     OLEMISC_SETCLIENTSITEFIRST;
  2220.   FToolboxBitmapID := ToolboxBitmapID;
  2221.   FEventTypeInfo := GetInterfaceTypeInfo(IMPLTYPEFLAG_FDEFAULT or
  2222.     IMPLTYPEFLAG_FSOURCE);
  2223.   if FEventTypeInfo <> nil then
  2224.   begin
  2225.     OleCheck(FEventTypeInfo.GetTypeAttr(TypeAttr));
  2226.     FEventIID := TypeAttr.guid;
  2227.     FEventTypeInfo.ReleaseTypeAttr(TypeAttr);
  2228.   end;
  2229.   FVerbs := TStringList.Create;
  2230.   AddVerb(OLEIVERB_PRIMARY, 'Properties');
  2231.   LicString := LicStr;
  2232.   SupportsLicensing := LicStr <> '';
  2233.   FLicFileStrings := TStringList.Create;
  2234. end;
  2235.  
  2236. destructor TActiveXControlFactory.Destroy;
  2237. begin
  2238.   FVerbs.Free;
  2239.   FLicFileStrings.Free;
  2240.   inherited Destroy;
  2241. end;
  2242.  
  2243. procedure TActiveXControlFactory.AddVerb(Verb: Integer;
  2244.   const VerbName: string);
  2245. begin
  2246.   FVerbs.AddObject(VerbName, TObject(Verb));
  2247. end;
  2248.  
  2249. function TActiveXControlFactory.GetLicenseFileName: string;
  2250. begin
  2251.   Result := ChangeFileExt(ComServer.ServerFileName, '.lic');
  2252. end;
  2253.  
  2254. function TActiveXControlFactory.HasMachineLicense: Boolean;
  2255. var
  2256.   i: Integer;
  2257. begin
  2258.   Result := True;
  2259.   if not SupportsLicensing then Exit;
  2260.   if not FLicenseFileRead then
  2261.   begin
  2262.     try
  2263.       FLicFileStrings.LoadFromFile(GetLicenseFileName);
  2264.       FLicenseFileRead := True;
  2265.     except
  2266.       Result := False;
  2267.     end;
  2268.   end;
  2269.   if Result then
  2270.   begin
  2271.     i := 0;
  2272.     Result := False;
  2273.     while (i < FLicFileStrings.Count) and (not Result) do
  2274.     begin
  2275.       Result := ValidateUserLicense(FLicFileStrings[i]);
  2276.       inc(i);
  2277.     end;
  2278.   end;
  2279. end;
  2280.  
  2281. procedure TActiveXControlFactory.UpdateRegistry(Register: Boolean);
  2282. var
  2283.   ClassKey: string;
  2284.   I: Integer;
  2285. begin
  2286.   ClassKey := 'CLSID\' + GUIDToString(ClassID);
  2287.   if Register then
  2288.   begin
  2289.     inherited UpdateRegistry(Register);
  2290.     CreateRegKey(ClassKey + '\MiscStatus', '', '0');
  2291.     CreateRegKey(ClassKey + '\MiscStatus\1', '', IntToStr(FMiscStatus));
  2292.     CreateRegKey(ClassKey + '\ToolboxBitmap32', '',
  2293.       ComServer.ServerFileName + ',' + IntToStr(FToolboxBitmapID));
  2294.     CreateRegKey(ClassKey + '\Control', '', '');
  2295.     CreateRegKey(ClassKey + '\Verb', '', '');
  2296.     for I := 0 to FVerbs.Count - 1 do
  2297.       CreateRegKey(ClassKey + '\Verb\' + IntToStr(Integer(FVerbs.Objects[I])),
  2298.         '', FVerbs[I] + ',0,2');
  2299.   end else
  2300.   begin
  2301.     for I := 0 to FVerbs.Count - 1 do
  2302.       DeleteRegKey(ClassKey + '\Verb\' + IntToStr(Integer(FVerbs.Objects[I])));
  2303.     DeleteRegKey(ClassKey + '\Verb');
  2304.     DeleteRegKey(ClassKey + '\Control');
  2305.     DeleteRegKey(ClassKey + '\ToolboxBitmap32');
  2306.     DeleteRegKey(ClassKey + '\MiscStatus\1');
  2307.     DeleteRegKey(ClassKey + '\MiscStatus');
  2308.     inherited UpdateRegistry(Register);
  2309.   end;
  2310. end;
  2311.  
  2312. { TActiveFormControl }
  2313.  
  2314. procedure TActiveFormControl.FreeOnRelease;
  2315. begin
  2316. end;
  2317.  
  2318. procedure TActiveFormControl.InitializeControl;
  2319. begin
  2320.   inherited InitializeControl;
  2321.   Control.VCLComObject := Pointer(Self as IVCLComObject);
  2322.   (Control as TActiveForm).Initialize;
  2323. end;
  2324.  
  2325. function TActiveFormControl.Invoke(DispID: Integer; const IID: TGUID;
  2326.   LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo,
  2327.   ArgErr: Pointer): HResult;
  2328. const
  2329.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  2330. begin
  2331.   if Flags and INVOKE_PROPERTYSET <> 0 then Flags := INVOKE_PROPERTYSET;
  2332.   Result := TAutoObjectFactory(Factory).DispTypeInfo.Invoke(Pointer(
  2333.     Integer(Control) + TAutoObjectFactory(Factory).DispIntfEntry.IOffset),
  2334.     DispID, Flags, TDispParams(Params), VarResult, ExcepInfo, ArgErr);
  2335. end;
  2336.  
  2337. function TActiveFormControl.ObjQueryInterface(const IID: TGUID; out Obj): Integer;
  2338. begin
  2339.   Result := S_OK;
  2340.   if not Control.GetInterface(IID, Obj) then
  2341.     Result := inherited ObjQueryInterface(IID, Obj);
  2342. end;
  2343.  
  2344. procedure TActiveFormControl.EventSinkChanged(const EventSink: IUnknown);
  2345. begin
  2346.   if (Control is TActiveForm) then
  2347.     TActiveForm(Control).EventSinkChanged(EventSink);
  2348. end;
  2349.  
  2350. { TActiveForm }
  2351.  
  2352. constructor TActiveForm.Create(AOwner: TComponent);
  2353. begin
  2354.   inherited Create(AOwner);
  2355.   FAxBorderStyle := afbSingle;
  2356.   BorderStyle := bsNone;
  2357.   BorderIcons := [];
  2358. end;
  2359.  
  2360. procedure TActiveForm.SetAxBorderStyle(Value: TActiveFormBorderStyle);
  2361. begin
  2362.   if FAxBorderStyle <> Value then
  2363.   begin
  2364.     FAxBorderStyle := Value;
  2365.     if not (csDesigning in ComponentState) then RecreateWnd;
  2366.   end;
  2367. end;
  2368.  
  2369. procedure TActiveForm.CreateParams(var Params: TCreateParams);
  2370. begin
  2371.   inherited CreateParams(Params);
  2372.   if not (csDesigning in ComponentState) then
  2373.     with Params do
  2374.     begin
  2375.       Style := Style and not WS_CAPTION;
  2376.       case FAxBorderStyle of
  2377.         afbNone: ;// do nothing
  2378.         afbSingle: Style := Style or WS_BORDER;
  2379.         afbSunken: ExStyle := ExStyle or WS_EX_CLIENTEDGE;
  2380.         afbRaised: ExStyle := ExStyle or WS_EX_WINDOWEDGE;
  2381.       end;
  2382.     end;
  2383. end;
  2384.  
  2385. procedure TActiveForm.EventSinkChanged(const EventSink: IUnknown);
  2386. begin
  2387. end;
  2388.  
  2389. procedure TActiveForm.Initialize;
  2390. begin
  2391. end;
  2392.  
  2393. { TActiveFormFactory }
  2394.  
  2395. function TActiveFormFactory.GetIntfEntry(Guid: TGUID): PInterfaceEntry;
  2396. begin
  2397.   Result := WinControlClass.GetInterfaceEntry(Guid);
  2398. end;
  2399.  
  2400. { TPropertyPage }
  2401.  
  2402. procedure TPropertyPage.CMChanged(var Msg: TCMChanged);
  2403. begin
  2404.   Modified;
  2405. end;
  2406.  
  2407. procedure TPropertyPage.Modified;
  2408. begin
  2409.   if Assigned(FActiveXPropertyPage) then FActiveXPropertyPage.Modified;
  2410. end;
  2411.  
  2412. procedure TPropertyPage.UpdateObject;
  2413. begin
  2414. end;
  2415.  
  2416. procedure TPropertyPage.EnumCtlProps(PropType: TGUID; PropNames: TStrings);
  2417. const
  2418.   INVOKE_PROPERTYSET = INVOKE_PROPERTYPUT or INVOKE_PROPERTYPUTREF;
  2419. var
  2420.   I: Integer;
  2421.   TypeInfo: ITypeInfo;
  2422.   Dispatch: IDispatch;
  2423.   TypeAttr: PTypeAttr;
  2424.   FuncDesc: PFuncDesc;
  2425.   VarDesc: PVarDesc;
  2426.  
  2427.   procedure SaveName(Id: Integer);
  2428.   var
  2429.     Name: WideString;
  2430.   begin
  2431.     OleCheck(TypeInfo.GetDocumentation(Id, @Name, nil, nil, nil));
  2432.     if PropNames.IndexOfObject(TObject(Id)) = -1 then
  2433.       PropNames.AddObject(Name, TObject(Id));
  2434.   end;
  2435.  
  2436.   function IsPropType(const TypeInfo: ITypeInfo; TypeDesc: PTypeDesc): Boolean;
  2437.   var
  2438.     RefInfo: ITypeInfo;
  2439.     RefAttr: PTypeAttr;
  2440.   begin
  2441.     Result := False;
  2442.     case TypeDesc.vt of
  2443.     VT_PTR: Result := IsPropType(TypeInfo, TypeDesc.ptdesc);
  2444.     VT_USERDEFINED:
  2445.       begin
  2446.         OleCheck(TypeInfo.GetRefTypeInfo(TypeDesc.hreftype, RefInfo));
  2447.         OleCheck(RefInfo.GetTypeAttr(RefAttr));
  2448.         try
  2449.           Result := IsEqualGUID(RefAttr.guid, PropType);
  2450.           if (not Boolean(Result)) and (RefAttr.typekind = TKIND_ALIAS) then
  2451.             Result := IsPropType(RefInfo, @RefAttr.tdescAlias);
  2452.         finally
  2453.           RefInfo.ReleaseTypeAttr(RefAttr);
  2454.         end;
  2455.       end;
  2456.     end;
  2457.   end;
  2458.  
  2459. begin
  2460.   Dispatch := IUnknown(FOleObject) as IDispatch;
  2461.   OleCheck(Dispatch.GetTypeInfo(0,0,TypeInfo));
  2462.   if TypeInfo = nil then Exit;
  2463.   OleCheck(TypeInfo.GetTypeAttr(TypeAttr));
  2464.   try
  2465.     for I := 0 to TypeAttr.cVars - 1 do
  2466.     begin
  2467.       OleCheck(TypeInfo.GetVarDesc(I, VarDesc));
  2468.       try
  2469.         if IsPropType(TypeInfo, @VarDesc.elemdescVar.tdesc) then
  2470.           SaveName(VarDesc.memid);
  2471.       finally
  2472.         TypeInfo.ReleaseVarDesc(VarDesc);
  2473.       end;
  2474.     end;
  2475.     for I := 0 to TypeAttr.cFuncs - 1 do
  2476.     begin
  2477.       OleCheck(TypeInfo.GetFuncDesc(I, FuncDesc));
  2478.       try
  2479.         if ((FuncDesc.invkind = INVOKE_PROPERTYGET) and
  2480.           IsPropType(TypeInfo, @FuncDesc.elemdescFunc.tdesc)) or
  2481.           ((FuncDesc.invkind = INVOKE_PROPERTYSET) and
  2482.           IsPropType(TypeInfo,
  2483.             @FuncDesc.lprgelemdescParam[FuncDesc.cParams - 1].tdesc)) then
  2484.             SaveName(FuncDesc.memid);
  2485.       finally
  2486.         TypeInfo.ReleaseFuncDesc(FuncDesc);
  2487.       end;
  2488.     end;
  2489.   finally
  2490.     TypeInfo.ReleaseTypeAttr(TypeAttr);
  2491.   end;
  2492. end;
  2493.  
  2494. procedure TPropertyPage.UpdatePropertyPage;
  2495. begin
  2496. end;
  2497.  
  2498. { TActiveXPropertyPage }
  2499.  
  2500. procedure TActiveXPropertyPage.Initialize;
  2501. begin
  2502.   FPropertyPage := TPropertyPageClass(Factory.ComClass).Create(nil);
  2503.   FPropertyPage.FActiveXPropertyPage := Self;
  2504.   FPropertyPage.BorderStyle := bsNone;
  2505.   FPropertyPage.Position := poDesigned;
  2506. end;
  2507.  
  2508. destructor TActiveXPropertyPage.Destroy;
  2509. begin
  2510.   FPropertyPage.Free;
  2511. end;
  2512.  
  2513. procedure TActiveXPropertyPage.Modified;
  2514. begin
  2515.   if FActive then
  2516.   begin
  2517.     FModified := True;
  2518.     if FPageSite <> nil then
  2519.       FPageSite.OnStatusChange(PROPPAGESTATUS_DIRTY or PROPPAGESTATUS_VALIDATE);
  2520.   end;
  2521. end;
  2522.  
  2523. { TActiveXPropertyPage.IPropertyPage }
  2524.  
  2525. function TActiveXPropertyPage.SetPageSite(
  2526.   const pageSite: IPropertyPageSite): HResult;
  2527. begin
  2528.   FPageSite := pageSite;
  2529.   Result := S_OK;
  2530. end;
  2531.  
  2532. function TActiveXPropertyPage.Activate(hwndParent: HWnd;
  2533.   const rc: TRect; bModal: BOOL): HResult;
  2534. begin
  2535.   try
  2536.     FPropertyPage.BoundsRect := rc;
  2537.     FPropertyPage.ParentWindow := hwndParent;
  2538.     if not VarIsNull(FPropertyPage.FOleObject) then
  2539.       FPropertyPage.UpdatePropertyPage;
  2540.     FActive:= True;
  2541.     FModified := False;
  2542.     Result := S_OK;
  2543.   except
  2544.     Result := HandleException;
  2545.   end;
  2546. end;
  2547.  
  2548. function TActiveXPropertyPage.Deactivate: HResult;
  2549. begin
  2550.   try
  2551.     FActive := False;
  2552.     FPropertyPage.Hide;
  2553.     FPropertyPage.ParentWindow := 0;
  2554.     Result := S_OK;
  2555.   except
  2556.     Result := HandleException;
  2557.   end;
  2558. end;
  2559.  
  2560. function TActiveXPropertyPage.GetPageInfo(
  2561.   out pageInfo: TPropPageInfo): HResult;
  2562. begin
  2563.   try
  2564.     FillChar(pageInfo.pszTitle, SizeOf(pageInfo) - 4, 0);
  2565.     pageInfo.pszTitle := CoAllocString(FPropertyPage.Caption);
  2566.     pageInfo.size.cx := FPropertyPage.Width;
  2567.     pageInfo.size.cy := FPropertyPage.Height;
  2568.     Result := S_OK;
  2569.   except
  2570.     Result := HandleException;
  2571.   end;
  2572. end;
  2573.  
  2574. function TActiveXPropertyPage.SetObjects(cObjects: Longint;
  2575.   pUnkList: PUnknownList): HResult;
  2576. begin
  2577.   try
  2578.     FPropertyPage.FOleObject := Null;
  2579.     if cObjects > 0 then
  2580.       FPropertyPage.FOleObject := pUnkList[0] as IDispatch;
  2581.     Result := S_OK;
  2582.   except
  2583.     Result := HandleException;
  2584.   end;
  2585. end;
  2586.  
  2587. function TActiveXPropertyPage.Show(nCmdShow: Integer): HResult;
  2588. begin
  2589.   try
  2590.     FPropertyPage.Visible := nCmdShow <> SW_HIDE;
  2591.     Result := S_OK;
  2592.   except
  2593.     Result := HandleException;
  2594.   end;
  2595. end;
  2596.  
  2597. function TActiveXPropertyPage.Move(const rect: TRect): HResult;
  2598. begin
  2599.   try
  2600.     FPropertyPage.BoundsRect := rect;
  2601.     Result := S_OK;
  2602.   except
  2603.     Result := HandleException;
  2604.   end;
  2605. end;
  2606.  
  2607. function TActiveXPropertyPage.IsPageDirty: HResult;
  2608. begin
  2609.   if FModified then Result := S_OK else Result := S_FALSE;
  2610. end;
  2611.  
  2612. function TActiveXPropertyPage.Apply: HResult;
  2613. begin
  2614.   try
  2615.     FPropertyPage.UpdateObject;
  2616.     if FPageSite <> nil then
  2617.       FPageSite.OnStatusChange(PROPPAGESTATUS_VALIDATE);
  2618.     FModified := False;
  2619.     Result := S_OK;
  2620.   except
  2621.     Result := HandleException;
  2622.   end;
  2623. end;
  2624.  
  2625. function TActiveXPropertyPage.Help(pszHelpDir: POleStr): HResult;
  2626. begin
  2627.   Result := E_NOTIMPL;
  2628. end;
  2629.  
  2630. function TActiveXPropertyPage.TranslateAccelerator(msg: PMsg): HResult;
  2631. begin
  2632.   try
  2633.     { For some reason VB bashes WS_EX_CONTROLPARENT, set it back }
  2634.     if FPropertyPage.WindowHandle <> 0 then
  2635.       SetWindowLong(FPropertyPage.Handle, GWL_EXSTYLE,
  2636.         GetWindowLong(FPropertyPage.Handle, GWL_EXSTYLE) or
  2637.         WS_EX_CONTROLPARENT);
  2638.     {!!!}
  2639.     Result := S_FALSE;
  2640.   except
  2641.     Result := HandleException;
  2642.   end;
  2643. end;
  2644.  
  2645. { TActiveXPropertyPage.IPropertyPage2 }
  2646.  
  2647. function TActiveXPropertyPage.EditProperty(dispid: TDispID): HResult;
  2648. begin
  2649.   Result := E_NOTIMPL; {!!!}
  2650. end;
  2651.  
  2652. { TActiveXPropertyPageFactory }
  2653.  
  2654. constructor TActiveXPropertyPageFactory.Create(ComServer: TComServerObject;
  2655.   PropertyPageClass: TPropertyPageClass; const ClassID: TGUID);
  2656. begin
  2657.   inherited Create(ComServer, TComClass(PropertyPageClass), ClassID,
  2658.     '', Format('%s property page', [PropertyPageClass.ClassName]),
  2659.     ciMultiInstance);
  2660. end;
  2661.  
  2662. function TActiveXPropertyPageFactory.CreateComObject(
  2663.   const Controller: IUnknown): TComObject;
  2664. begin
  2665.   Result := TActiveXPropertyPage.CreateFromFactory(Self, Controller);
  2666. end;
  2667.  
  2668. { TCustomAdapter }
  2669.  
  2670. constructor TCustomAdapter.Create;
  2671. begin
  2672.   FNotifier := TAdapterNotifier.Create(Self);
  2673. end;
  2674.  
  2675. destructor TCustomAdapter.Destroy;
  2676. begin
  2677.   ReleaseOleObject;
  2678. end;
  2679.  
  2680. procedure TCustomAdapter.Changed;
  2681. begin
  2682.   if not Updating then ReleaseOleObject;
  2683. end;
  2684.  
  2685. procedure TCustomAdapter.ConnectOleObject(OleObject: IUnknown);
  2686. begin
  2687.   if FOleObject <> nil then ReleaseOleObject;
  2688.   InterfaceConnect(OleObject, IPropertyNotifySink, FNotifier, FConnection);
  2689.   FOleObject := OleObject;
  2690. end;
  2691.  
  2692. procedure TCustomAdapter.ReleaseOleObject;
  2693. begin
  2694.   InterfaceDisconnect(FOleObject, IPropertyNotifySink, FConnection);
  2695.   FOleObject := nil;
  2696. end;
  2697.  
  2698. { TAdapterNotifier }
  2699.  
  2700. constructor TAdapterNotifier.Create(Adapter: TCustomAdapter);
  2701. begin
  2702.   FAdapter := Adapter;
  2703. end;
  2704.  
  2705. { TAdapterNotifier.IPropertyNotifySink }
  2706.  
  2707. function TAdapterNotifier.OnChanged(dispid: TDispID): HResult;
  2708. begin
  2709.   try
  2710.     FAdapter.Update;
  2711.     Result := S_OK;
  2712.   except
  2713.     Result := HandleException;
  2714.   end;
  2715. end;
  2716.  
  2717. function TAdapterNotifier.OnRequestEdit(dispid: TDispID): HResult;
  2718. begin
  2719.   Result := S_OK;
  2720. end;
  2721.  
  2722. { TFontAdapter }
  2723.  
  2724. constructor TFontAdapter.Create(Font: TFont);
  2725. begin
  2726.   inherited Create;
  2727.   FFont := Font;
  2728. end;
  2729.  
  2730. procedure TFontAdapter.Update;
  2731. var
  2732.   TempFont: TFont;
  2733.   Name: WideString;
  2734.   Size: Currency;
  2735.   Temp: Longbool;
  2736.   Charset: Smallint;
  2737.   Style: TFontStyles;
  2738.   FOleFont: IFont;
  2739. begin
  2740.   if Updating then Exit;
  2741.   FOleFont := FOleObject as IFont;
  2742.   FOleFont.get_Name(Name);
  2743.   FOleFont.get_Size(Size);
  2744.  
  2745.   Style := [];
  2746.   FOleFont.get_Bold(Temp);
  2747.   if Temp then Include(Style, fsBold);
  2748.   FOleFont.get_Italic(Temp);
  2749.   if Temp then Include(Style, fsItalic);
  2750.   FOleFont.get_Underline(Temp);
  2751.   if Temp then Include(Style, fsUnderline);
  2752.   FOleFont.get_Strikethrough(Temp);
  2753.   if Temp then Include(Style, fsStrikeout);
  2754.   FOleFont.get_Charset(Charset);
  2755.  
  2756.   TempFont := TFont.Create;
  2757.   Updating := True;
  2758.   try
  2759.     TempFont.Assign(FFont);
  2760.     TempFont.Name := Name;
  2761.     TempFont.Size := Round(Size);
  2762.     TempFont.Style := Style;
  2763.     TempFont.Charset := Charset;
  2764.     FFont.Assign(TempFont);
  2765.   finally
  2766.     Updating := False;
  2767.     TempFont.Free;
  2768.   end;
  2769. end;
  2770.  
  2771. procedure TFontAdapter.Changed;
  2772. begin  // TFont has changed.  Need to update IFont
  2773.   if Updating then Exit;
  2774.   Updating := True;
  2775.   try
  2776.     with FOleObject as IFont do
  2777.     begin
  2778.       Put_Name(FFont.Name);
  2779.       Put_Size(FFont.Size);
  2780.       Put_Bold(fsBold in FFont.Style);
  2781.       Put_Italic(fsItalic in FFont.Style);
  2782.       Put_Underline(fsUnderline in FFont.Style);
  2783.       Put_Strikethrough(fsStrikeout in FFont.Style);
  2784.       Put_Charset(FFont.Charset);
  2785.     end;
  2786.   finally
  2787.     Updating := False;
  2788.   end;
  2789. end;
  2790.  
  2791. { TFontAdapter.IFontAccess }
  2792.  
  2793. procedure TFontAdapter.GetOleFont(var OleFont: IFontDisp);
  2794. var
  2795.   FontDesc: TFontDesc;
  2796.   FontName: WideString;
  2797.   Temp: IFont;
  2798. begin
  2799.   if FOleObject = nil then
  2800.   begin
  2801.     FontName := FFont.Name;
  2802.     with FontDesc do
  2803.     begin
  2804.       cbSizeOfStruct := SizeOf(FontDesc);
  2805.       lpstrName := PWideChar(FontName);
  2806.       cySize := FFont.Size;
  2807.       if fsBold in FFont.Style then sWeight := 700 else sWeight := 400;
  2808.       sCharset := FFont.Charset;
  2809.       fItalic := fsItalic in FFont.Style;
  2810.       fUnderline := fsUnderline in FFont.Style;
  2811.       fStrikethrough := fsStrikeout in FFont.Style;
  2812.     end;
  2813.     OleCheck(OleCreateFontIndirect(FontDesc, IFont, Temp));
  2814.     ConnectOleObject(Temp);
  2815.   end;
  2816.   OleFont := FOleObject as IFontDisp;
  2817. end;
  2818.  
  2819. procedure TFontAdapter.SetOleFont(const OleFont: IFontDisp);
  2820. begin
  2821.   ConnectOleObject(OleFont as IFont);
  2822.   Update;
  2823. end;
  2824.  
  2825. { TPictureAdapter }
  2826.  
  2827. constructor TPictureAdapter.Create(Picture: TPicture);
  2828. begin
  2829.   inherited Create;
  2830.   FPicture := Picture;
  2831. end;
  2832.  
  2833. procedure TPictureAdapter.Update;
  2834. var
  2835.   Temp: TOleGraphic;
  2836. begin
  2837.   Updating := True;
  2838.   Temp := TOleGraphic.Create;
  2839.   try
  2840.     Temp.Picture := FOleObject as IPicture;
  2841.     FPicture.Graphic := Temp;
  2842.   finally
  2843.     Updating := False;
  2844.     Temp.Free;
  2845.   end;
  2846. end;
  2847.  
  2848. { TPictureAdapter.IPictureAccess }
  2849.  
  2850. procedure TPictureAdapter.GetOlePicture(var OlePicture: IPictureDisp);
  2851. var
  2852.   PictureDesc: TPictDesc;
  2853.   OwnHandle: Boolean;
  2854.   TempM: TMetafile;
  2855.   TempB: TBitmap;
  2856. begin
  2857.   if FOleObject = nil then
  2858.   begin
  2859.     OwnHandle := False;
  2860.     with PictureDesc do
  2861.     begin
  2862.       cbSizeOfStruct := SizeOf(PictureDesc);
  2863.       if FPicture.Graphic is TBitmap then
  2864.       begin
  2865.         picType := PICTYPE_BITMAP;
  2866.         TempB := TBitmap.Create;
  2867.         try
  2868.           TempB.Assign(FPicture.Graphic);
  2869.           hbitmap := TempB.ReleaseHandle;
  2870.           hpal := TempB.ReleasePalette;
  2871.           OwnHandle := True;
  2872.         finally
  2873.           TempB.Free;
  2874.         end;
  2875.       end
  2876.       else if FPicture.Graphic is TIcon then
  2877.       begin
  2878.         picType := PICTYPE_ICON;
  2879.         hicon := FPicture.Icon.Handle;
  2880.       end
  2881.       else
  2882.       begin
  2883.         picType := PICTYPE_ENHMETAFILE;
  2884.         if not (FPicture.Graphic is TMetafile) then
  2885.         begin
  2886.           TempM := TMetafile.Create;
  2887.           try
  2888.             TempM.Width := FPicture.Width;
  2889.             TempM.Height := FPicture.Height;
  2890.             with TMetafileCanvas.Create(TempM,0) do
  2891.             try
  2892.               Draw(0,0,FPicture.Graphic);
  2893.             finally
  2894.               Free;
  2895.             end;
  2896.             hemf := TempM.ReleaseHandle;
  2897.             OwnHandle := True;   // IPicture destroys temp metafile when released
  2898.           finally
  2899.             TempM.Free;
  2900.           end;
  2901.         end
  2902.         else
  2903.           hemf := FPicture.Metafile.Handle;
  2904.       end;
  2905.     end;
  2906.     OleCheck(OleCreatePictureIndirect(PictureDesc, IPicture, OwnHandle, OlePicture));
  2907.     ConnectOleObject(OlePicture);
  2908.   end;
  2909.   OlePicture := FOleObject as IPictureDisp;
  2910. end;
  2911.  
  2912. procedure TPictureAdapter.SetOlePicture(const OlePicture: IPictureDisp);
  2913. begin
  2914.   ConnectOleObject(OlePicture);
  2915.   Update;
  2916. end;
  2917.  
  2918. { TOleGraphic }
  2919.  
  2920. procedure TOleGraphic.Assign(Source: TPersistent);
  2921. begin
  2922.   if Source is TOleGraphic then
  2923.     FPicture := TOleGraphic(Source).Picture
  2924.   else
  2925.     inherited Assign(Source);
  2926. end;
  2927.  
  2928. procedure TOleGraphic.Changed(Sender: TObject);
  2929. begin
  2930.   //!!
  2931. end;
  2932.  
  2933. procedure TOleGraphic.Draw(ACanvas: TCanvas; const Rect: TRect);
  2934. var
  2935.   DC: HDC;
  2936.   Pal: HPalette;
  2937.   RestorePalette: Boolean;
  2938.   PicType: SmallInt;
  2939.   hemf: HENHMETAFILE;
  2940. begin
  2941.   if FPicture = nil then Exit;
  2942.   ACanvas.Lock;  // OLE calls might cycle the message loop
  2943.   try
  2944.     DC := ACanvas.Handle;
  2945.     Pal := Palette;
  2946.     RestorePalette := False;
  2947.     if Pal <> 0 then
  2948.     begin
  2949.       Pal := SelectPalette(DC, Pal, True);
  2950.       RealizePalette(DC);
  2951.       RestorePalette := True;
  2952.     end;
  2953.     FPicture.get_Type(PicType);
  2954.     if PicType = PICTYPE_ENHMETAFILE then
  2955.     begin
  2956.       FPicture.get_Handle(hemf);
  2957.       PlayEnhMetafile(DC, hemf, Rect);
  2958.     end
  2959.     else
  2960.       OleCheck(FPicture.Render(DC, Rect.Left, Rect.Top, Rect.Right,
  2961.         Rect.Bottom, 0, MMHeight, MMWidth, -MMHeight, Rect));
  2962.     if RestorePalette then
  2963.       SelectPalette(DC, Pal, True);
  2964.   finally
  2965.     ACanvas.Unlock;
  2966.   end;
  2967. end;
  2968.  
  2969. function TOleGraphic.GetEmpty: Boolean;
  2970. var
  2971.   PicType: Smallint;
  2972. begin
  2973.   Result := (FPicture = nil) or (FPicture.get_Type(PicType) <> 0) or (PicType <= 0);
  2974. end;
  2975.  
  2976. function HIMETRICtoDP(P: TPoint): TPoint;
  2977. var
  2978.   DC: HDC;
  2979. begin
  2980.   DC := GetDC(0);
  2981.   SetMapMode(DC, MM_HIMETRIC);
  2982.   Result := P;
  2983.   Result.Y := -Result.Y;
  2984.   LPTODP(DC, Result, 1);
  2985.   ReleaseDC(0,DC);
  2986. end;
  2987.  
  2988. function TOleGraphic.GetHeight: Integer;
  2989. begin
  2990.   Result := HIMETRICtoDP(Point(0, MMHeight)).Y;
  2991. end;
  2992.  
  2993. function TOleGraphic.GetMMHeight: Integer;
  2994. begin
  2995.   Result := 0;
  2996.   if FPicture <> nil then FPicture.get_Height(Result);
  2997. end;
  2998.  
  2999. function TOleGraphic.GetMMWidth: Integer;
  3000. begin
  3001.   Result := 0;
  3002.   if FPicture <> nil then FPicture.get_Width(Result);
  3003. end;
  3004.  
  3005. function TOleGraphic.GetPalette: HPALETTE;
  3006. begin
  3007.   Result := 0;
  3008.   if FPicture <> nil then FPicture.Get_HPal(Result);
  3009. end;
  3010.  
  3011. function TOleGraphic.GetTransparent: Boolean;
  3012. var
  3013.   Attr: Integer;
  3014. begin
  3015.   Result := False;
  3016.   if FPicture <> nil then
  3017.   begin
  3018.     FPicture.Get_Attributes(Attr);
  3019.     Result := (Attr and PICTURE_TRANSPARENT) <> 0;
  3020.   end;
  3021. end;
  3022.  
  3023. function TOleGraphic.GetWidth: Integer;
  3024. begin
  3025.   Result := HIMETRICtoDP(Point(MMWidth,0)).X;
  3026. end;
  3027.  
  3028. procedure InvalidOperation(const Str: string);
  3029. begin
  3030.   raise EInvalidGraphicOperation.Create(Str);
  3031. end;
  3032.  
  3033. procedure TOleGraphic.SetHeight(Value: Integer);
  3034. begin
  3035.   InvalidOperation(sOleGraphic);
  3036. end;
  3037.  
  3038. procedure TOleGraphic.SetPalette(Value: HPALETTE);
  3039. begin
  3040.   if FPicture <> nil then OleCheck(FPicture.Set_hpal(Value));
  3041. end;
  3042.  
  3043. procedure TOleGraphic.SetWidth(Value: Integer);
  3044. begin
  3045.   InvalidOperation(sOleGraphic);
  3046. end;
  3047.  
  3048. procedure TOleGraphic.LoadFromFile(const Filename: string);
  3049. begin
  3050.   //!!
  3051. end;
  3052.  
  3053. procedure TOleGraphic.LoadFromStream(Stream: TStream);
  3054. begin
  3055.   //!!
  3056. end;
  3057.  
  3058. procedure TOleGraphic.SaveToStream(Stream: TStream);
  3059. begin
  3060.   //!!
  3061. end;
  3062.  
  3063. procedure TOleGraphic.LoadFromClipboardFormat(AFormat: Word; AData: THandle;
  3064.   APalette: HPALETTE);
  3065. begin
  3066.   InvalidOperation(sOleGraphic);
  3067. end;
  3068.  
  3069. procedure TOleGraphic.SaveToClipboardFormat(var AFormat: Word;
  3070.   var AData: THandle; var APalette: HPALETTE);
  3071. begin
  3072.   InvalidOperation(sOleGraphic);
  3073. end;
  3074.  
  3075.  
  3076. type
  3077.   TStringsEnumerator = class(TContainedObject, IEnumString)
  3078.   private
  3079.     FIndex: Integer;  // index of next unread string
  3080.     FStrings: IStrings;
  3081.   public
  3082.     constructor Create(const Strings: IStrings);
  3083.     function Next(celt: Longint; out elt;
  3084.       pceltFetched: PLongint): HResult; stdcall;
  3085.     function Skip(celt: Longint): HResult; stdcall;
  3086.     function Reset: HResult; stdcall;
  3087.     function Clone(out enm: IEnumString): HResult; stdcall;
  3088.   end;
  3089.  
  3090. constructor TStringsEnumerator.Create(const Strings: IStrings);
  3091. begin
  3092.   inherited Create(Strings);
  3093.   FStrings := Strings;
  3094. end;
  3095.  
  3096. function TStringsEnumerator.Next(celt: Longint; out elt; pceltFetched: PLongint): HResult;
  3097. var
  3098.   I: Integer;
  3099. begin
  3100.   I := 0;
  3101.   while (I < celt) and (FIndex < FStrings.Count) do
  3102.   begin
  3103.     TPointerList(elt)[I] := PWideChar(WideString(FStrings.Item[I]));
  3104.     Inc(I);
  3105.     Inc(FIndex);
  3106.   end;
  3107.   if pceltFetched <> nil then pceltFetched^ := I;
  3108.   if I = celt then Result := S_OK else Result := S_FALSE;
  3109. end;
  3110.  
  3111. function TStringsEnumerator.Skip(celt: Longint): HResult;
  3112. begin
  3113.   if (FIndex + celt) <= FStrings.Count then
  3114.   begin
  3115.     Inc(FIndex, celt);
  3116.     Result := S_OK;
  3117.   end
  3118.   else
  3119.   begin
  3120.     FIndex := FStrings.Count;
  3121.     Result := S_FALSE;
  3122.   end;
  3123. end;
  3124.  
  3125. function TStringsEnumerator.Reset: HResult;
  3126. begin
  3127.   FIndex := 0;
  3128.   Result := S_OK;
  3129. end;
  3130.  
  3131. function TStringsEnumerator.Clone(out enm: IEnumString): HResult;
  3132. begin
  3133.   enm := Self.Create(FStrings);
  3134.   Result := S_OK;
  3135. end;
  3136.  
  3137. { TStringsAdapter }
  3138.  
  3139. constructor TStringsAdapter.Create(Strings: TStrings);
  3140. var
  3141.   StdVcl: ITypeLib;
  3142. begin
  3143.   OleCheck(LoadRegTypeLib(LIBID_STDVCL, 1, 0, 0, StdVcl));
  3144.   inherited Create(StdVcl, IStrings);
  3145.   FStrings := Strings;
  3146. end;
  3147.  
  3148. procedure TStringsAdapter.ReferenceStrings(S: TStrings);
  3149. begin
  3150.   FStrings := S;
  3151. end;
  3152.  
  3153. procedure TStringsAdapter.ReleaseStrings;
  3154. begin
  3155.   FStrings := nil;
  3156. end;
  3157.  
  3158. function TStringsAdapter.Get_ControlDefault(Index: Integer): OleVariant;
  3159. begin
  3160.   Result := Get_Item(Index);
  3161. end;
  3162.  
  3163. procedure TStringsAdapter.Set_ControlDefault(Index: Integer; Value: OleVariant);
  3164. begin
  3165.   Set_Item(Index, Value);
  3166. end;
  3167.  
  3168. function TStringsAdapter.Count: Integer;
  3169. begin
  3170.   Result := 0;
  3171.   if FStrings <> nil then Result := FStrings.Count;
  3172. end;
  3173.  
  3174. function TStringsAdapter.Get_Item(Index: Integer): OleVariant;
  3175. begin
  3176.   Result := NULL;
  3177.   if (FStrings <> nil) then Result := WideString(FStrings[Index]);
  3178. end;
  3179.  
  3180. procedure TStringsAdapter.Set_Item(Index: Integer; Value: OleVariant);
  3181. begin
  3182.   if (FStrings <> nil) then FStrings[Index] := Value;
  3183. end;
  3184.  
  3185. procedure TStringsAdapter.Remove(Index: Integer);
  3186. begin
  3187.   if FStrings <> nil then FStrings.Delete(Index);
  3188. end;
  3189.  
  3190. procedure TStringsAdapter.Clear;
  3191. begin
  3192.   if FStrings <> nil then FStrings.Clear;
  3193. end;
  3194.  
  3195. function TStringsAdapter.Add(Item: OleVariant): Integer;
  3196. begin
  3197.   Result := -1;
  3198.   if FStrings <> nil then Result := FStrings.Add(Item);
  3199. end;
  3200.  
  3201. function TStringsAdapter._NewEnum: IUnknown;
  3202. begin
  3203.   Result := TStringsEnumerator.Create(Self);
  3204. end;
  3205.  
  3206. procedure GetOleStrings(Strings: TStrings; var OleStrings: IStrings);
  3207. begin
  3208.   OleStrings := nil;
  3209.   if Strings = nil then Exit;
  3210.   if Strings.StringsAdapter = nil then
  3211.     Strings.StringsAdapter := TStringsAdapter.Create(Strings);
  3212.   OleStrings := Strings.StringsAdapter as IStrings;
  3213. end;
  3214.  
  3215. procedure SetOleStrings(Strings: TStrings; const OleStrings: IStrings);
  3216. var
  3217.   I: Integer;
  3218. begin
  3219.   if Strings = nil then Exit;
  3220.   Strings.Clear;
  3221.   for I := 0 to OleStrings.Count-1 do
  3222.     Strings.Add(OleStrings.Item[I]);
  3223. end;
  3224.  
  3225. { Dynamically load functions used in OLEPRO32.DLL }
  3226.  
  3227. var
  3228.   OlePro32DLL: THandle;
  3229.   _OleCreatePropertyFrame: function(hwndOwner: HWnd; x, y: Integer;
  3230.     lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
  3231.     pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
  3232.     pvReserved: Pointer): HResult stdcall;
  3233.   _OleCreateFontIndirect: function(const FontDesc: TFontDesc; const iid: TIID;
  3234.     out vObject): HResult stdcall;
  3235.   _OleCreatePictureIndirect: function(const PictDesc: TPictDesc; const iid: TIID;
  3236.     fOwn: BOOL; out vObject): HResult stdcall;
  3237.  
  3238. procedure InitOlePro32;
  3239. var
  3240.   OldError: Longint;
  3241. begin
  3242.   OldError := SetErrorMode(SEM_NOOPENFILEERRORBOX);
  3243.   try
  3244.     if OlePro32DLL = 0 then
  3245.     begin
  3246.        OlePro32DLL := LoadLibrary('olepro32.dll');
  3247.       if (OlePro32DLL >= 0) and (OlePro32DLL < 32) then OlePro32DLL := 0;
  3248.       if OlePro32DLL <> 0 then
  3249.       begin
  3250.         @_OleCreatePropertyFrame := GetProcAddress(OlePro32DLL, 'OleCreatePropertyFrame');
  3251.         @_OleCreateFontIndirect := GetProcAddress(OlePro32DLL, 'OleCreateFontIndirect');
  3252.         @_OleCreatePictureIndirect := GetProcAddress(OlePro32DLL, 'OleCreatePictureIndirect');
  3253.       end;
  3254.     end;
  3255.   finally
  3256.     SetErrorMode(OldError);
  3257.   end;
  3258. end;
  3259.  
  3260. function OleCreatePropertyFrame(hwndOwner: HWnd; x, y: Integer;
  3261.   lpszCaption: POleStr; cObjects: Integer; pObjects: Pointer; cPages: Integer;
  3262.   pPageCLSIDs: Pointer; lcid: TLCID; dwReserved: Longint;
  3263.   pvReserved: Pointer): HResult;
  3264. begin
  3265.   if Assigned(_OleCreatePropertyFrame) then
  3266.     Result := _OleCreatePropertyFrame(hwndOwner, x, y, lpszCaption, cObjects,
  3267.       pObjects, cPages, pPageCLSIDs, lcid, dwReserved, pvReserved)
  3268.   else
  3269.     Result := E_UNEXPECTED;
  3270. end;
  3271.  
  3272. function OleCreateFontIndirect(const FontDesc: TFontDesc; const iid: TIID;
  3273.   out vObject): HResult;
  3274. begin
  3275.   if Assigned(_OleCreateFontIndirect) then
  3276.     Result := _OleCreateFontIndirect(FontDesc, iid, vObject)
  3277.   else
  3278.     Result := E_UNEXPECTED;
  3279. end;
  3280.  
  3281. function OleCreatePictureIndirect(const PictDesc: TPictDesc; const iid: TIID;
  3282.   fOwn: BOOL; out vObject): HResult;
  3283. begin
  3284.   if Assigned(_OleCreatePictureIndirect) then
  3285.     Result := _OleCreatePictureIndirect(PictDesc, iid, fOwn, vObject)
  3286.   else
  3287.     Result := E_UNEXPECTED;
  3288. end;
  3289.  
  3290. initialization
  3291.   InitOlePro32;
  3292. finalization
  3293.   if xParkingWindow <> 0 then DestroyWindow(xParkingWindow);
  3294. //  if OlePro32DLL <> 0 then FreeLibrary(OlePro32DLL);
  3295. end.
  3296.